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ABSTRACT 

Programming  languages  have  been  and  will  continue  to  be  an 
important  instrument  for  the  automation  of  a  wide  variety  of 
functions  within  industry  and  the  Federal  Government.  Other 
instruments,  such  as  program  generators,  application  packages, 
query  languages,  and  the  like,  are  also  available  and  their  use 
is  preferable  in  some  circumstances. 

Given  that  conventional  programming  is  the  appropriate 
technique  for  a  particular  application,  the  choice  among  the 
various  languages  becomes  an  important  issue.  There  are  a  great 
number  of  selection  criteria,  not  all  of  which  depend  directly  on 
the  language  itself.  Broadly  speaking,  the  criteria  are  based  on 
1)  the  language  and  its  implementation,  2)  the  application  to  be 
programmed,   and  3)   the  user's  existing  facilities  and  software. 

This  study  presents  a  survey  of  selection  factors  for  the 
major  general-purpose  languages:  Ada*,  BASIC,  C,  COBOL,  FORTRAN, 
Pascal,  and  PL/I.  The  factors  covered  include  not  only  the 
logical  operations  within  each  language,  but  also  the  advantages 
and  disadvantages  stemming  from  the  current  computing 
environment,  e.g.f  software  packages,  microcomputers,  and 
standards.  The  criteria  associated  with  the  application  and  the 
user-'s  facilities  are  explained.  Finally,  there  is  a  set  of 
program  examples  to  illustrate  the  features  of  the  various 
languages . 

This  volume  includes  the  program  examples.  Volume  1 
contains  the  discussion  of  language  selection  criteria. 

Key  words ;  Ada;  alternatives  to  programming;  BASIC;  C; 
COBOL;  FORTRAN;  Pascal;  PL/I;  programming  language 
features;  programming  languages;  selection  of  programming 
language . 


•  Ada  is  a  registered  trademark  of  the  U.   S.  Government, 
Ada  Joint  Project  Office. 
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1.0  INTRODUCTION 

In  this  volume,  we  shall  illustrate  the  general  style  of 
each  of  the  languages  with  a  program.  These  programs  are  only 
examples;  they  do  not  attempt  to  demonstrate  the  full  capability 
of  each  language.  On  the  other  hand,  the  application  chosen  is 
complex  enough  that  the  programs  do  make  significant  use  of 
several  important  language  features,  such  as  reading  a  file, 
interacting  with  a  user,  recursion,  data  abstraction, 
manipulation  of  arrays,  pointers,  and  character  strings,  and  some 
numeric  calculation.  Of  particular  note  are  the  language 
features  for  modularizing  a  program  of  moderate  size  (about  1000 
lines).  While  no  application  can  be  completely  lang uag e - ne u t r a 1 , 
this  variety  of  requirements  implies  a  relatively  unbiased 
example.  Finally,  the  application  deals  with  a  well-known  realm 
(family  relationships)  in  order  to  facilitate  understanding  of 
the   programs . 

All  of  the  programs  solve  the  same  problem,  i.e.,  they 
accept  the  same  input  and  produce  output  as  nearly  equivalent  as 
possible.  The  input  is  a  file  of  people,  one  person  per  record, 
and  a  series  of  user  queries.  In  the  file,  each  person's  father 
and  mother  (if  known),  and  spouse  (if  any)  are  identified.  Given 
this  information,  the  user  may  then  specify  any  two  persons  in 
the  file,  and  the  program  computes  and  displays  the  relationship 
(e.g.,  brother-in-law,  second  cousin)  between  those  two.  Also, 
based  on  the  number  and  degree  of  common  ancestors,  the  expected 
value  for  the  proportion  of  common  genetic  material  between  the 
two   is    computed   and  displayed. 

The  algorithms  and  data  structures  employed  are  roughly 
equivalent,  but  differ  in  detail  owing  to  the  language 
differences  being  illustrated.  Generally,  user-defined  names  are 
capitalized  and  language-defined  keywords  and  identifiers  are 
written  in  lower-case.  In  all  the  programs  a  directed  graph  is 
simulated,  with  the  vertices  representing  people  and  the  edges 
representing  different  types  of  direct  relationships.  The  only 
direct  relationships  are  parent,  child,  and  spouse.  Starting  at 
one  vertex,  a  search  is  conducted  to  find  the  shortest  path  to 
the  other  vertex.  The  types  of  edges  encountered  along  the  path, 
together  with  some  additional  information,  determine  the 
relationship.  For  instance,  if  the  shortest  path  between  XI  and 
X4  is  that  XI  is  child  of  X2 ,  X2  is  spouse  of  X3 ,  and  X3  is 
parent  of  X4,  this  would  show  that  XI  and  X4  are  step-siblings. 
It  is  assumed  that  the  input  file  has  already  been  validated  and 
is  correct.  The  user's  requests,  however,  are  checked.  The 
algorithm  to  determine  the  shortest  path  is  adapted  from 
[Baas78].  The  overall  algorithm  is  expressed  by  the  pseudo-code 
below. 

All  of  the  programs,  except  the  one  in  BASIC,  have  compiled 
and  executed  on  at  least  one  language  processor  which  implements 
the  corresponding  standard  or  base  document.  The  COBOL  program, 
while  conforming  to  both  COBOL-74  and  C0B0L-8x,  is  essentially  a 
COBOL-74  program,  since  it  does  not  exploit  any  of  the  new 
COBOL-Sx  features. 
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Figure    1   -  Algorithm   for   Program  Examples 

for   each   record   in   input    PEOPLE   file  do 
establish   entry   in   PERSON  array 
for   all   previous   entries  do 

compare    this   entry   to   previous,    looking  for 

i  mm  ediate   relationships:    parent,    child,    or  spouse 
if   relationship  found 

establish   link   (edge)    between   these   two  persons 
end  if 
end  for 
end  for 

graph   is   now  built 

while   not   request    to  stop 

prompt   and   read   next  request 
exit   while-block   if   request    to  stop 
if    syntax   of   request  OK 

search   for   requested  persons 
if   exactly  one   of   each   person  found 
if    1st   person  =   2nd  person 

display   "identical    to  self" 
else 

find   shortest   path   between   the    two  persons 
if   no   such  path 

display  "unrelated" 
else 

analyze   path   for   named  relationships: 

path   initially   composed   of   parent,  child, 

spouse  edges 
resolve   child-parent   and  child-spouse-parent 

to  sibling 

resolve   child-child-...    and  parent-parent-... 

to   descendant    (child*)    or   ancestor  (parent' 
resolve   child*-sibling-parent*    to  cousin, 
chi Id*- s ibl ing   to  nephew, 
sibling-parent*   to  uncle 
display   consolidated  relationships 
compute   proportion   of   common   genetic  material: 
traverse   ancestors   of   personl,    zeroing  out 
traverse   ancestors   of   personl,   marking  and 

accumulating  genetic  contribution 
traverse   ancestors   of   person2,  accumulating 

overlap  with  personl 
display  results 

end  if 
end    i  f 
else 

display   "duplicate   name"    or    "not  found" 
end  if 
else 

display   "invalid  request" 
end  if 
end  while 
display  "done" 
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This  figure 
program  examples 

Position 


1-20 
21-23 
24 
25-21 
28-30 
31-33 


Figure    2   -    Input  Data 


shows  some  of 
were  tested. 

Contents 


the  Input  data  with  which 
The   format   of   each   record  is: 


the 


Name   of  person 
Unique    3-digit  identifier 
Gender   of  person 
Identifier   of    father  (000 
Identifier   of   mother  (000 
Identifier   of   spouse  (000 


of  person 

if  unknown) 

if  unknown) 

if  none   or  unknown) 


Example   of   Input  Data 


John  Smith 

Mary  Smith 

Wilbur  Finnegan 

Mary  Finnegan 

James  Smith 

Wilma  Smith 

Marvin  Hamlisch 

Melvln  Hamlisch 

Martha  Hamlisch 

Murgatroyd  Whatsis 

Bentley  Whatsis 

Myrna  Whozat 

Bosworth  Whatsis 

K48 

K43 

K41 

K42 

K46 

K45 

K47 

K44 

Velorus  Davis 
Goldle  Beacon 
Ross  Beacon 
Velma  Davis 
Floyd  Davis 
Cindy  Davis 
David  Beacon 
Norma  Cousins 
Carmine  Cousins 
Maria  Cousins 
James  Cousins 
C.    John  Cousins 
John  Cousins 
Janet  Cousins 
Richard  Cousins 
Paul  Cousins 
Marie  Cousins 


001M000000002 
002F003000001 
OlOMOOOOOOOll 
OllFOOOOOOOlO 
020M001002022 
022F010011020 
031M000032000 
033M000032000 
032F048043034 
034M000000032 
035M034036000 
036F000000000 
037M034036000 
048M000000043 
043F041042048 
041M000000042 
042F000000041 
046M045000000 
045M048043000 
047M044000000 
044M041042000 
085M000000086 
083F085086082 
082M000000083 
086F000000085 
088M085084087 
084F000000000 
121M081 120000 
053F082083055 
051M000000052 
052F000000051 
054M051052000 
055M051052053 
073M055053074 
074F140141073 
077M073074000 
078M073074000 
079F073074000 
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Figure   3   -  Queries   and  Output 

This    figure   gives    some   examples   of   the      results     of  running 
the   programs . 

Enter   two   person-identifiers    (name   or  number), 
separated  by   semicolon.    Enter   "stop"    to  stop. 

Incorrect   request   format:    null   field   preceding  semicolon. 

Enter   two  pe r s on- i den t i f ie r s    (name   or  number), 

separated  by   semicolon.    Enter    "stop"    to  stop. 
X ;  X  ;  X 

Incorrect  request   format:    must   be   exactly   one  semicolon. 

Enter   two   pe r s on- i den t i f i e r s    (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop. 
X ;  X 

First    person   not  found. 
Second   person  not  found. 

Enter    two   person-identifiers    (name   or  number), 
separated  by   semicolon.    Enter   "stop"    to  stop. 

Ill        ;  111 
Christopher   Delmonte    is    identical    to  himself. 

Enter   two   per s on- i den t i f i e r s    (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop. 
G6;John  Smith 


G6 

i  s 

not  re 

lated 

to   John  Sm 

Enter   two  person-identi 

f  ie  rs  ( 

name 

or  number ) , 

separated   by  semicolon. 

Enter 

"stop 

to  stop. 

Carmine  Cousins;lll 

Duplicate   names  for 

fir 

St   per  son  - 

use   nume r i c 

Enter   two  person-identi 

f  ie  r s  ( 

name 

or   number ) , 

separated   by  semicolon. 

Enter 

"stop 

to  stop. 

163 ;  145 

Shortest    path   between  identifi 

ed  persons: 

Linda  Lackluster 

i  s 

child 

of 

Millie  Lackluster 

i  s 

child 

of 

Anna  Pittypat 

i  s 

parent 

of 

Margaret  Madison 

i  s 

spouse 

of 

Richard  Madison 

i  s 

child 

of 

Victoria  Pisces 

i  s 

parent 

of 

Maria  Gotsocks 

is 

parent 

of 

Elzbieta  Gotsocks 

Condensed    path : 

Linda  Lackluster 

i  s 

niece 

of 

Richard  Madison 

is 

uncle 

of 

Elzbieta  Gotsocks 

Proportion   of   common   genetic   material   =  O.OOOOOE+00 


Figure    3   -   Queries   and    Output  (continued) 


Enter    two   pe r s on- id  en t i f i e r s    (name   or  number) 
separated   by    semicolon.    Enter    "stop"    to  stop. 
094 ; 145 

between 


persons 


Shortest  path 
Nancy  Powers 
Maxine  Powers 
Floyd  Davis 
Velorus  Davis 
Goldie  Beacon 
Norma  Cousins 
John  Cousins 
Janet  Cousins 
Richard  Madison 
Victoria  Pisces 
Maria  Gotsocks 
Elzbieta  Gotsocks 
Condensed  path: 
Nancy  Powers 
Janet  Cousins 
Elzbieta  Gotsocks 

Proportion   of   common   genetic   material  = 


id 

en  t  i  f  i 

ed 

is 

child 

of 

i  s 

child 

of 

is 

child 

of 

is 

parent 

of 

is 

parent 

of 

i  s 

parent 

of 

is 

spouse 

of 

is 

child 

of 

is 

child 

of 

i  s 

parent 

of 

is 

parent 

of 

i  s 

2nd  half- 

i  s 

cousin 

of 

of 


0. OOOOOE+00 


Enter  two 
separated 
036;033 
Shortest  path 
Myrna  Whozat 
Bentley  Whatsis 
Murgatroyd  Whatsis 
Martha  Hamlisch 
Melvin  Hamlisch 
Condensed  path: 
Myrna  Whozat 
Bentley  Whatsis 
Melvin  Hamlisch 
Proportion   of  common 


pe r s on- i den t i f ie r s  (name  or  number), 
by   semicolon.    Enter    "stop"    to  stop. 


between   identified  persons 
is    parent  of 


1  s 
is 
is 


1  s 
is 


child  of 
spouse  of 
parent 


of 


mother  of 
step-brother 


of 


genetic   material   =  O.OOOOOE+00 


Enter   two   person-identifiers   (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop. 
031 ; 033 

Shortest   path   between   identified  persons: 
Marvin   Hamlisch  is   child  of 

Martha   Hamlisch  is   parent  of 

Melvin  Hamlisch 
Condensed  path: 

Marvin   Hamlisch  is   half-brother  of 

Melvin  Hamlisch 

Proportion   of   common  genetic  material   =  2.50000E-01 
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Figure   3   -   Queries   and   Output  (continued) 

Enter   two   pe r s on- i den t i f i e r s    (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop. 
145 ; 090 


Shortest   path  between 

identif i 

ed 

Elzbieta  Gotsocks 

is 

child 

of 

Maria  Gotsocks 

i  s 

child 

of 

U .  Pisces 

is 

parent 

of 

Richard  Madison 

i  s 

parent 

of 

Janet  Cousins 

is 

spouse 

of 

John  Cousins 

i  s 

child 

of 

Norma  Cousins 

is 

child 

of 

Goldie  Beacon 

i  s 

child 

of 

Velorus  Davis 

i  s 

parent 

of 

Floyd  Davis 

i  s 

parent 

of 

Maxine  Powers 

is 

spouse 

of 

Tim  Powers 
Condensed  path: 

Elzbieta   Gotsocks  is    cousin-in-law  of 

John  Cousins  is  hal f - co u s in- in- la w  once  removed  of 
Tim  Powers 

Proportion   of   common  genetic   material   =  O.OOOOOE+00 


Enter   two   pe r s on- i den t i f ie r s    (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop. 
L6  ;R9 


Shortest 

path   between  identifi 

ed  persons 

L6 

is 

child 

of 

L5 

i  s 

child 

of 

L4 

i  s 

child 

of 

L3 

i  s 

child 

of 

L2 

i  s 

child 

of 

LI 

i  s 

child 

of 

LO 

is 

parent 

of 

Rl 

i  s 

parent 

of 

R2 

i  s 

parent 

of 

R3 

i  s 

parent 

of 

R4 

is 

parent 

of 

R5 

i  s 

parent 

of 

R6 

is 

parent 

of 

R7 

i  s 

parent 

of 

R8 

is 

parent 

of 

R9 

Condensed    path : 

L6  is    5th   half-cousin   3   times   removed  of 

R9 

Proportion   of    common   genetic   material    =  3.05176E-05 
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Figure    3   -   Queries    and    Output  (continued) 


Enter    two  pers 
separated  by  s 
Wl : R14 


o n- id e n t i f i e r s  (name  or  number), 
emicolon.    Enter   "stop"    to  stop. 

persons : 


Slhor  te  s  t 

path 

between  identified 

Wl 

i  s 

spouse  of 

LO 

Is 

parent  of 

Rl 

is 

parent  of 

R2 

i  s 

parent  of 

R3 

is 

parent  of 

R4 

is 

parent  of 

R5 

is 

parent  of 

R6 

i  s 

parent  of 

R7 

is 

parent  of 

R8 

i  s 

parent  of 

R9 

is 

parent  of 

RIO 

is 

parent  of 

Rll 

is 

parent  of 

R12 

is 

parent  of 

R13 

is 

parent  of 

R14 

Condensed 

path 

Wl 

i  s 

great*12- 

R14 

Proportion  of  common  genetic  material  =  O.OOOOOE+00 
Enter   two   pe r s on- i den t i f ie rs  (name 


separated 

by 

semicolon . 

Enter  "st 

X8  ;L6 

Shortest 

path 

between  i 

dent  if  ied 

X8 

is 

child  of 

X7 

i  s 

child  of 

X6 

i  s 

child  of 

X5 

i  s 

child  of 

X4 

is 

child  of 

X3 

is 

spouse  of 

R4 

is 

child  of 

R3 

is 

child  of 

R2 

is 

child  of 

Rl 

i  s 

child  of 

LO 

i  s 

parent  of 

LI 

i  s 

parent  of 

L2 

is 

parent  of 

L3 

i  s 

parent  of 

L4 

is 

parent  of 

L5 

is 

parent  of 

L6 

or  number ) , 
I "    to  stop. 


persons 


Condensed 

X8 

R4 

L6 

Proportion 


path 


is   great*3-grand-step-son  of 

is   3rd   half-cousin   2   times  removed 


of 


of    common   genetic   material   =  O.OOOOOE+00 
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Figure   3   -   Queries   and   Output  (continued) 

Enter   two   person-identifiers    (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop. 
G5  ;G6 

Shortest   path   between   identified  persons: 

G5  is   parent  of 

06 

Condensed  path: 

G5  is   mother  of 

G6 

Proportion   of   common   genetic  material   =  5.62500E-01 

Enter   two   person-identifiers    (name   or  number), 
separated   by   semicolon.    Enter    "stop"    to  stop, 
stop 

End   of   re  la t ion- f inde r  . 
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2.0  ADA 


  first  compilation-unit  #1  is  package  of  global  types  and  objects 

package  RELATION  TYPES  AND  DATA  is 


MAX_PERSONS 
NAME  LENGTH 


constant  integer  :=  300; 
constant  integer  :=  20; 


—  every  PERSON  has  a  unique  3-digit  IDENTIFIER 


IDENTIF IER_LENGTH 
BUFFER  LENGTH 


constant  integer  :=  3; 
constant  integer   :=  60; 


subtype 

NAME  RANGE 

is 

subtype 

IDENTIFIER  RANGE 

is 

subtype 

BUFFER_RANGE 

is 

subtype 

NAME  TYPE 

is 

subtype 

BUFFER  TYPE 

is 

subtype 

MESSAGE  TYPE 

is 

subtype 

INDEX  TYPE 

is 

subtype 

COUNTER 

is 

subtype 

DIGIT  TYPE 

is 

type  REAL 

is 

type  IDENTIFIER  TYPE 

is 

IDENTIFIER  LENGTH; 


range  0. .MAX_PERSONS ; 
range  0. . integer'last ; 
ranee  '0'  . . '9' ; 


—  each  person's  record  in  the  file  identifies  at  most  three 

—  others  directly  related:  father,  mother,  and  spouse 

type  GIVEN_IDENTIFIERS        is  (FATHER_IDENT,  MOTHER_IDENT,   SPOUSE_IDENT ) ; 
type  RELATIVE  ARRAY  is  array  (GIVEN  IDENTIFIERS)  of  IDENTIFIER  TYPE; 


NULL_IDENT 
REQUESTJDK 

"Request  OK 
REQUEST_TO_STOP 

"stop 


constant  IDENTIF lERJTYPE  := 
constant  MESSAGEJTYPE  := 

constant  BUFFER  TYPE  := 


•OOO' 


type  GENDERJTYPE 
type  RELATION  TYPE 


is  (MALE,  FEMALE); 

is  (PARENT,  CHILD,   SPOUSE,   SIBLING,  UNCLE, 
NEPHEW,  COUSIN,  NULL_RELATION) ; 

—  directed  edges  in  the  graph  are  of  a  given  subtype 
subtype  EDGE_TYPE  is  RELATION_TYPE  range  PARENT. . SPOUSE ; 

—  A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 

—  is  immediately  adjacent  to  those  reached,  or  farther  away, 
type  REACHEDJTYPE  is  (REACHED,  NEARBY,  NOT_SEEN); 

—  each  PERSON  has  a  linked  list  of  adjacent  nodes,  called  neighbors 
type  NEIGHBOR_RECORD; 

type  NEIGHBOR_POINTER    is  access  NEIGHBOR_RECORD; 
type  NEIGHBOR_RECORD  is 
record 

NEIGHBOR_INDEX        :  INDEX_TYPE; 
NEIGHBOR_EDGE  :  EDGE_TYPE; 

NEXT_NEIGHBOR  :  NEIGHBOR_POINTER; 

end  record; 
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—  All  relationships  are  captured  in  the  directed  graph  of  which 

—  each  record  is  a  node, 
type  PERSON_RECORD  is 

record 

—  static  information  -  filled  from  PEOPLE  file: 
NAME  :  NAME_TYPE; 
IDENTIFIER  :   IDENTIFIERJTYPE ; 
GENDER                              :   GENDERJTYPE ; 

—  IDENTIFIERS  of  immediate  relatives  -  father,  mother,  spouse 
RELATIVE_IDENTIFIER       :  RELATIVE_ARRAY; 

—  head  of  linked  list  of  adjacent  nodes 
NEIGHBOR_LIST_HEADER     :  NEIGHBOR_POINTER; 

—  data  used  when  traversing  graph  to  resolve  user  request : 


REAL; 

INDEX_TYPE; 
EDGE_TYPE ; 
REACHED  TYPE; 


D I S TANCE_F  ROM_S OURCE 

PATH_PREDECESSOR 

EDGE_TO_PREDECESSOR 

REACHED_STATUS 
—  data  used  to  compute  common  genetic  material 

DESCENDANT_IDENTIFIER  :  IDENTIFIERJTYPE; 

DESCENDANT_GENES  :  REAL; 

end  record; 

—  the  PERSON  array  is  the  central  repository  of  information 

—  about  inter-relationships. 

PERSON  :  array  (INDEX_TYPE)  of  PERSON_RECORD; 

—  utility  to  truncate  or  fill  with  spaces 

procedure  COERCE_STRING  (SOURCE   :  in  string;   TARGET  :  in  out  string); 
end  RELATION_TYPES_AND_DATA; 
  END  SPECIFICATION    BEGIN  BODY   


package  body  RELATION_TYPES_AND_DATA  is 

procedure  COERCE_STRING  (SOURCE   :  in  string;   TARGET  :  in  out  string)  is 
MANY  SPACES   :   constant  string  (1..100)  := 


begin 

if  SOURCE'length  <  TARGET'length  then 

TARGET  (TARGET' first ..TARGET' first  +  SOURCE' length  -  1)  :=  SOURCE 
TARGET  (TARGET'first  +  SOURCE 'length .. TARGET'last)  := 
MANY_SPACES  ( 1 .. TARGET'length  -  SOURCE' length) ; 
else      —  SOURCE  longer  than  TARGET 

TARGET  :=  SOURCE (SOURCE 'first .. SOURCE 'first  +  TARGET'length  -  1); 
end  if ; 
end  COERCE_STRING; 
end  RELATION  TYPES  AND  DATA; 


—  new  compilation-unit  #2:  main  line  of  execution  RELATE 


with  RELATION_TYPES_AND_DATA,   text_io,  sequent ial_io ; 
use     RELATION_TYPES_AND_DATA,  text_io; 

procedure  RELATE  is 

—  this  is  the  format  of  records  in  the  file  to  be  read  in 
type  FILE_GENDER  is  ('M',  'F'); 

type  FILE_PERSON_RECORD  is 
record 

NAME  :  NAMEJTYPE; 

IDENTIFIER  :   IDENTIFIER_TYPE ; 

—  'M'  for  MALE  and  'F'  for  FEMALE 
GENDER  :  FILE_GENDER; 

RELATIVE_IDENTIFIER  :  RELATIVE_ARRAY; 
end  record; 

—  Instantiate  generic  package  for  file  10. 
package  PEOPLE_IO  is 

new  sequential_io  (ELEMENTJTYPE  =>  FILE_PERSON_RECORD) ; 

—  These  variables  are  used  when  establishing  the  PERSON  array 

—  from  the  PEOPLE  file. 

PEOPLE  :   PEOPLE_IO  .  FILEJTYPE; 

PEOPLE_RECORD  :  FILE_PERSON_RECORD; 

C URRENT ,  NUMBER_OF_PERS ONS 

:  INDEX_TYPE; 
PREVIOUS_IDENT,  CURRENT_IDENT 

:  "rDENTIFIER_TYPE; 
RELATIONSHIP  :   GIVEN_IDENTIFIERS ; 

—  These  variables  are  used  to  accept  and  resolve  requests  for 

—  RELATIONSHIP  information. 
BUFFER_INDEX,  SEMICOLON_LOCATION 

:  BUFFER_RANGE ; 
REQUEST_BUFFER  :  BUFFERJTYPE ; 

PERS0N1_IDENT,  PERS0N2_IDENT 

:  NAMEJTYPE; 
PERS0N1_F0UND,  PERS0N2_F0UND 

:  COUNTER; 
ERROR_MESSAGE  :  MESSAGE_TYPE ; 

PERS0N1_INDEX,  PERS0N2_INDEX 

:   INDEX  TYPE; 
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—  declare  procedures  directly  Invoked  from  RELATE: 

procedure  LINK_RELATIVES  (FROM_INDEX       :   in  INDEXJTYPE ; 

RELATIONSHIP  :  in  GIVEN_IDENTIFIERS ; 
TO_INDEX  :   in  INDEXJTYPE) 

is  separate; 
procedure  PROMPT_AND_READ  is  separate; 

procedure  CHECK_REQUEST  (REQUEST_STATUS  :  out  MESSAGE_TYPE ; 

SEMICOLON_LOCATION  :  out  BUFFER_RANGE ) 

is  separate; 

procedure  BUFFER_TO_PERSON  (PERSON_ID  :   in  out  NAME_TYPE ; 

START_LOCATION, 

STOP_LOCATION  :  in  BUFFER_RANGE ) 

is  separate; 
procedure  SE ARC H_F OR_RE QUE S TED_PE RS ONS 

(PERS0N1_IDENT,   PERS0N2_IDENT  :   in     NAMEJTYPE ; 
PERS0N1_INDEX,   PERS0N2_INDEX  :  out  INDEX_TYPE; 
PERS0N1_F0UND,   PERS0N2_F0UND  :   in  out  COUNTER) 
is  separate; 

procedure  FIND_RELATIONSHIP  ( TARGE T_INDEX,   SOURCE_INDEX  :   in  INDEX_TYPE) 
is  separate; 

—  ***  execution  of  main  sequence  begins  here  ***  — 
begin 

PEOPLE_IO  .  open  (PEOPLE,   PEOPLE_IO  .   IN_FILE,  "PEOPLE.DAT"); 

—  CURRENT  location  in  array  being  filled 
CURRENT  :=  0; 

—  This  loop  reads  in  the  PEOPLE  file  and  constructs  the  PERSON 

—  array  from  it  (one  PERSON  =  one  record  =  one  array  entry). 

—  As  records  are  read  in,  links  are  constructed  to  represent  the 

—  PARENT-CHILD  or  SPOUSE  RELATIONSHIP.     The  array  then  implements 

—  a  directed  graph  which  is  used  to  satisfy  subsequent  user 

—  requests.     The  file  is  assumed  to  be  correct  -  no  validation 

—  is  performed  on  it. 
READ_IN_PEOPLE: 

while  not  PEOPLE_IO  .  end_of_file  (PEOPLE)  loop 
PEOPLE_IO  .  read  (PEOPLE,   PEOPLE_RECORD ) ; 
CURRENT  :=  CURRENT+1 ; 

—  copy  direct  information  from  file  to  array 
PERSON  (CURRENT)   .  NAME  :=  PEOPLE_RECORD  .  NAME; 

PERSON  (CURRENT)   .  IDENTIFIER       :=  PEOPLE_RECORD  .  IDENTIFIER; 
if  PEOPLE_RECORD  .  GENDER  =  'M'  then 
PERSON  (CURRENT)   .  GENDER  :=  MALE; 
else 

PERSON  (CURRENT)   .  GENDER  :=  FEMALE; 
end  if ; 

PERSON  (CURRENT)   .  RELATIVE_IDENTIFIER  := 

PEOPLE_RECORD  .  RELATIVE_IDENTIFIER; 
--  Location  of  adjacent  persons  as  yet  undetermined 
PERSON  (CURRENT)   .   NEIGHBOR_LIST_HEADER  :=  null; 
~  Descendants  as  yet  undetermined 

PERSON  (CURRENT)    .  DESCENDANT_IDENTIFIER  :=  NULL_IDENT; 
CURRENT  IDENT   :=  PERSON  (CURRENT)   .  IDENTIFIER; 


—  Compare  this  PERSON  against  all  previously  entered  PERSONS 

—  to  search  for  RELATIONSHIPS. 
COMPARE_TO_PRE  VIOUS : 

for  PREVIOUS  in  1..CURRENT-1  loop 

PREVIOUS_IDENT       :=  PERSON  (PREVIOUS)    .  IDENTIFIER; 
RELATIONSHIP  :=  FATHER_IDENT ; 

—  Search  for  father,  mother,  or  spouse  relationship  in 

—  either  direction  between  this  and  PREVIOUS  PERSON. 

—  Assume  at  most  one  RELATIONSHIP  exists. 
TRY_ALL_RELATIONSHIPS : 

loop 

if  PERSON  (CURRENT)   .  RELATIVE_IDENTIFIER  (RELATIONSHIP)  = 

PREVIOUS_IDENT 
then 

LINK_RELATIVES  (CURRENT,  RELATIONSHIP,  PREVIOUS); 
exit  TRY_ALL_RELATIONSHIPS ; 
else 

if  CURRENT_IDENT  = 

PERSON  (PREVIOUS)   .  RELATIVE_IDENTIFIER  (RELATIONSHIP) 
then 

LINK_RELATIVES  (PREVIOUS,  RELATIONSHIP,  CURRENT); 
exit  TRY_ALL_RELATIONSHIPS ; 
end  if ; 
end  if ; 

if  RELATIONSHIP  <  SPOUSE_IDENT  then 

RELATIONSHIP  :=  GIVEN_IDENTIFIERS'succ(RELATIONSHIP) ; 
else 

exit  TRY_ALL_RELATIONSHIPS ; 
end  if ; 

end  loop  TRY_ALL_RELATIONSHIPS ; 
end  loop  COMPARE_TO_PREVIOUS ; 
end  loop  READ_IN_PEOPLE ; 
NUMBER_OF_PERSONS  :=  CURRENT; 
PEOPLE_IO   .  close  (PEOPLE); 

—  PERSON  array  is  now  loaded  and  edges  between  immediate  relatives 

—  (PARENT -CHILD  or  SPOUSE -SPOUSE)  are  established. 

—  While-loop  accepts  requests  and  finds  RELATIONSHIP  (if  any) 

—  between  pairs  of  PERSONS . 
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READ_AND_PROCESS_REQUEST : 
loop 

PROMPT_AND_READ ; 

exit  READ_AND_PROCESS_REQUEST  when  REQUEST_BUFFER  =  REQUEST_TO_STOP; 
CHECK_REQUEST  (ERROR_MESSAGE,   SEMICOLON_LOCATION) ; 

—  Syntax  check  of  request  completed.     Now  either  display  error 
■ —  message  or  search  for  the  two  PERSONS. 

if  ERROR_MESSAGE  =  REQUEST_OK  then 

—  Request  syntactically  correct  - 

—  search  for  requested  PERSONS. 
BUFFER_TO_PERSON  (PERS0N1_IDENT,   1,   SEMICOLON_LOCATION  -  1); 
BUFFER_TO_PERSON  (PERS0N2_IDENT ,   SEMICOLON_LOCATION  +  1,   BUFFER_LENGTH) ; 
SEARCH_FOR_REQUESTED_PERSONS   (PERS0N1_IDENT,  PERS0N2_IDENT, 

PERS0N1_INDEX,  PERS0N2_INDEX, 
PERS0N1_F0UND,   PERS0N2_F0UND) ; 
if  (PERS0N1_F0UND  =  1)  and  (PERS0N2_F0UND  =  1)  then 

—  Exactly  one  match  for  each  PERSON  -  proceed  to 

—  determine  RELATIONSHIP,  if  any. 

if  PERS0N1_INDEX  =  PERS0N2_INDEX  then 

put  ('  '  &  PERSON  (PERS0N1_INDEX)   .   NAME  & 

is  identical  to  "); 
if  PERSON  (PERS0N1_INDEX)   .  GENDER  =  MALE  then 

put_line( "himself . " ) ; 
else 

put_line( "herself . " ) ; 
end  if ; 
else 

FIND_RELATIONSHIP  (PERS0N1_INDEX,   PERS0N2_INDEX) ; 
end  if ; 

else      —  either  not  found  or  more  than  one  found 
if  PERS0N1_F0UND  =  0  then 

put_line  ("  First  person  not  found."); 
elsif  PERS0N1_F0UND  >  1  then 

put_line  ("  Duplicate  names  for  first  person  -  use"  & 
numeric  identifier."); 

end  if ; 

if  PERS0N2_F0UND  =  0  then 

put_line  ("  Second  person  not  found."); 
elsif  PERS0N2_F0UND  >  1  then 

put_line  ("  Duplicate  names  for  second  person  -  use"  & 
numeric  identifier."); 

end  if ; 

end  if;      —  processing  of  syntactically  legal  request 
else 

put_line  ("  Incorrect  request  format:   "  &  ERROR_MESSAGE ) ; 
end  if ; 

end  loop  READ_AND_PROCESS_REQUEST ; 
put_line  ("  End  of  relation-finder."); 
end  RELATE; 
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  new  compilation-unit  #3:   procedures  under  RELATE 

separate  (RELATE) 

procedure  LINK_RELATIVES  (FROM_INDEX       :  in  INDEXJTYPE ; 

RELATIONSHIP  :   in  GIVEN_IDENTIFIERS ; 
TO_INDEX  :  in  INDEXJTYPE)  is 

—  establishes  cross-indexing  between  immediately  related  PERSONS. 

procedure  LINK_ONE_WAY  (FROM_INDEX  :  in  INDEX_TYPE; 

THIS_EDGE     :   in  EDGE_TYPE ; 
TO_INDEX       :  in  INDEXJTYPE)  is 
~  Establishes  the  NEIGHBOR_RECORD  from  one  PERSON  to  another 

NEW_NEIGHBOR  :  NEIGHBORJPOINTER ; 

beg  in 

NEW_NEIGHBOR  :=  new  NEIGHBOR_RECORD 
'(NEIGHBOR_INDEX  =>  TO_INDEX, 
NEIGHBOR_EDGE     =>  THIS_EDGE, 

NEXTJIEIGHBOR    =>  PERSON  (FROM_INDEX)   .  NEIGHBORJLIST_HEADER) ; 
PERSON  (FROM_INDEX)   .  NEIGHBOR_LIST_HEADER  :=  NEW_NEIGHBOR; 
end; 

begin      —  execution  of  LINK_RELATIVES 
if  RELATIONSHIP  =  SPOUSE_IDENT  then 

LINKJDNEJWAY  (FROM_INDEX,   SPOUSE,  TO_INDEX); 
LINK_ONE_WAY  (TO_INDEX,  SPOUSE,  FROM_INDEX); 
else      —  RELATIONSHIP  is  father  or  mother 

LINK_ONE_WAY  (FROM_INDEX,   PARENT,  TO_INDEX); 
LINKJ3NE_WAY  (TO_INDEX,   CHILD,  FROM_INDEX); 
end  if ; 
end  LINK_RELATIVES; 

separate  (RELATE) 

procedure  PROMPT_AND_READ  is 

—  Issues  prompt  for  user-request,  reads  in  request, 

—  blank-fills  buffer,  and  skips  to  next  line  of  input. 

LAST_FILLED  :  natural; 

begin 

put_line  ("  "); 

put_line  ("  "); 

put_line  ("  Enter  two  person-identifiers  (name  or  number),"); 
put_line  ("  separated  by  semicolon.  Enter  ""stop""  to  stop."); 
get~line  (REQUEST_BUFFER,  LAST_F ILLED ) ; 

COERCE_STRING  ("   ",  REQUEST_BUFFER  (LAST_FILLED+1 . . BUFFER_LENGTH) ) ; 
end  PROMPT  AND  READ; 
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separate  (RELATE) 

procedure  CHECK_REQUEST  (REQUEST_STATUS  :  out  MESSAGE_TYPE ; 

SEMICOLON_LOCATION  :  out  BUFFER_RANGE )  is 

—  Performs  syntactic  check  on  request  in  buffer. 

SEMICOLONJCOUNT        :  COUNTER; 
PERS0N1_F  IELD_EXISTS ,   PERS0N2_F IELD_EXI STS 

:  boolean; 

beg  in 

REQUEST_STATUS  :=  REQUEST_OK; 

SEMICOLON_LOCATION       :=  1; 
PERS0N1_FIELD_EXISTS   :=  false; 
PERS0N2_FIELD_EXISTS  :=  false; 
SEMICOLON_COUNT  :=  0; 

for  BUFFER_INDEX  in  BUFFER_RANGE  loop 

if  REQUEST_BUFFER  (BUFFER_INDEX)  /=  '  '  then 
if  REQUEST_BUFFER  (BUFFER_INDEX)  =  ';'  then 
SEMICOLON_LOCATION  :=  BUFFER_INDEX; 
SEMICOLON_COUNT        :=  SEMICOLONJCOUNT  +  1; 
else      —  Check  for  non-blanks  before/after  semicolon, 
if  SEMICOLONJCOUNT  <  1  then 

PERS0N1_FIELD_EXISTS   :=  true; 
else 

PERS0N2_FIELD_EXISTS  :=  true; 
end  if ; 
end  if; 
end  if ; 
end  loop; 

—  set  REQUEST_STATUS,  based  on  results  of  scan  of  REQUEST_BUFFER. 
if  SEMICOLON_COUNT  /=  1  then 

REQUEST_STATUS   :=  "must  be  exactly  one  semicolon.  "; 
elsif  not  PERS0N1_FIELD_EXISTS  then 

REQUEST_STATUS   :=  "null  field  preceding  semicolon.  "; 
elsif  not  PERS0N2_FIELD_EXISTS  then 

REQUEST_STATUS   :=  "null  field  following  semicolon.  "; 
end  if ; 
end  CHECK_REQUEST; 

separate  (RELATE) 

procedure  BUFFER_TO_PERSON  (PERSON_ID  :  in  out  NAMEJIYPE ; 

START_LOCATION, 

STOPJ.OCATION  :  in  BUFFERJIANGE )  is 

—  fills  in  the  PERSON_ID  from  the  designated  portion 

—  of  the  REQUEST_BUFFER. 

FIRST_NON_BLANK  :  BUFFER_RANGE ; 
begin 

FIRST_NON_BLANK  :=  STARTJ.OCATION; 

while  REQUEST_BUFFER  (FIRST_NON_BLANK)  =  '  '  loop 

FIRST JJON_BLANK  :=  FIRSTJS10N_BLANK  +  1; 
end  loop ; 

COERCE_STRING  (REQUEST_BUFFER  (FIRST_NON_BLANK. . STOP_LOCATION) , 
PERSON_ID); 
end  BUFFER  TO  PERSON; 


separate  (RELATE) 

procedure  SEARCH_FOR_REQUESTED_PERSONS 

(PERS0N1_IDENT,   PERS0N2_IDENT  :   in     NAME_TYPE ; 

PERS0N1_INDEX,   PERS0N2_INDEX  :  out  INDEX_TYPE; 

PERS0N1_F0UND,   PERS0N2_F0UND  :   in  out  COUNTER)  is 

—  SEARCH_FOR_REQUESTED_PERSONS  scans  through  the  PERSON  array, 

—  looking  for  the  two  requested  PERSONS.  Match  may  be  by  NAME 

—  or  unique  IDENTIFIER-number . 

THIS_IDENT  :  NAMEJTYPE ; 

begin 

PERSON 1_F0UND  :=  0; 

PERS0N2_F0UND  :=  0; 

PERS0N1_INDEX  :=  0; 

PERS0N2_INDEX  :=  0; 
SCAN_ALL_PERSONS : 

for  CURRENT    in  1. .NUMBER_OF_PERSONS  loop 

—  THIS_IDENT  contains  CURRENT  PERSON'S  numeric  IDENTIFIER 

—  left- justified ,  padded  with  blanks. 
COERCE_STRING  ( "  " ,  THIS_IDENT); 

for  IDENTIFIER_INDEX  in  IDENTIFIER_RANGE  loop 
THIS_IDENT  (IDENTIFIER_INDEX)  := 

PERSON  (CURRENT)   .  IDENTIFIER  (IDENTIFIER_INDEX) ; 
end  loop; 

—  allow  identification  by  name  or  number, 
if  (PERS0N1_IDENT  =  THIS_IDENT)  or 

(PERS0N1_IDENT  =  PERSON  (CURRENT)   .  NAME) 
then 

PERS0N1_F0UND  :=  PERS0N1_F0UND  +  1; 
PERS0N1_INDEX  :=  CURRENT; 
end  if ; 

if  (PERS0N2_IDENT  =  THIS_IDENT)  or 

(PERS0N2_IDENr  =  PERSON  (CURRENT)   .  NAME) 
then 

PERS0N2_F0UND  :=  PERS0N2_F0UND  +  1; 
PERS0N2_INDEX  :=  CURRENT; 
end  if; 
end  loop  SCAN_ALL_PERSONS ; 
end  SEARCH  FOR  REQUESTED  PERSONS; 
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separate  (RELATE) 

procedure  FIND_RELATIONSHIP  ( TARGE T_INDEX,   SOURCE_INDEX  :  in  INDEXJTYPE) 

—  Finds  shortest  path  (if  any)  between  two  PERSONS  and 

—  determines  their  RELATIONSHIP  based  on  immediate  relations 

—  traversed  in  path.     PERSON  array  simulates  a  directed  graph, 

—  and  algorithm  finds  shortest  path,  based  on  following 

—  weights:   PARENT -CHILD  edge    =  1.0 

SPOUSE-SPOUSE  edge  =  1.8 

type  SEARCH  TYPE  is  (SEARCHING,  SUCCEEDED,  FAILED); 


SEARCH_STATUS  :   SEARCH_TYPE ; 

THIS_NODE,  ADJACENT_NODE,  BEST_NEARBY_INDEX,  LAST_NEARBY_INDEX 

INDEX_TYPE; 

array  (INDEX_TYPE)  of  INDEX_TYPE ; 
EDGE_TYPE ; 
NEIGHBOR_POINTER; 
GIVEN_IDENTIFIERS ; 
REAL; 


NEARBY_NODE 
THIS_EDGE 
THIS_NEIGHBOR 
RELATIONSHIP 
MINIMAL  DISTANCE 


procedure  PROCESS  ADJACENT  NODE  (BASE  NODE,  NEXT  NODE   :  in  INDEX  TYPE; 


NEXT_BASE_EDGE 

is  separate; 
procedure  RESOLVE_PATH_TO_ENGLISH  is  separate; 
procedure  COMPUTE_COMMON_GENES   (INDEXl,   INDEX2  : 

is  separate; 


in  EDGE  TYPE) 


in  INDEX  TYPE) 


begin      —  execution  of  FIND_RELATIONSHIP 

—  initialize  PERSON-array  for  processing  - 

—  mark  all  nodes  as  not  seen 

for  PERSON_INDEX  in  1 . . NUMBER_OF_PERSONS  loop 

PERSON  (PERSON_INDEX)   .  REACHED_STATUS  :=  NOT_SEEN; 
end  loop; 

THIS_NODE   :=  SOURCE_INDEX; 

—  mark  source  node  as  REACHED 

PERSON  (THIS_NODE)   .  REACHED_STATUS  :=  REACHED; 

PERSON  (THIS_NODE)   .  DISTANCE_FROM_SOURCE  :=  0.0; 

—  no  NEARBY  nodes  exist  yet 
LAST_NEARBY_INDEX  :=  0; 

if  THIS_NODE  =  TARGE T_INDEX  then 

SEARCH_STATUS  :=  SUCCEEDED; 
else 

SEARCH_STATUS   :=  SEARCHING; 
end  if ; 
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—  Loop  keeps  processing  closest-to-source ,  unREACHED  node 

—  until  target  REACHED,  or  no  more  connected  nodes. 
SEARCH_FOR_TARGET : 

while  SEARCH_STATUS  =  SEARCHING  loop 

—  Process  all  nodes  adjacent  to  THIS_NODE 

THIS_NEIGHBOR  :=  PERSON  (THIS_NODE)   .  NEIGHBOR_LIST_HEADER ; 
while  THIS_NEIGHBOR  /=  null  loop 
PROCESS_ADJACENT_NODE   (THIS_NODE , 

THIS_NEIGHBOR  .  NEIGHBOR_INDEX, 
THIS_NEIGHBOR  .  NEIGHBOR_EDGE ) ; 
THISJJEIGHBOR  :=  THIS_NEIGHBOR  .  NEXT_NEIGHBOR ; 
end  loop; 


—  All  nodes  adjacent  to  THIS_NODE  are  set.     Now  search  for 

—  shortest-distance  unREACHED  (but  NEARBY)  node  to  process  next.- 
if  LAST_NEARBY_INDEX  =  0  then 

SEARCH_STATUS  :=  FAILED; 
else      —  determine  next  node  to  process 
MINIMAL_DI STANCE  :=  l.Oe+18; 

for  PERSON_INDEX  in  1 . . LAST_NEARBY_INDEX  loop 

if  PERSON  (NEARBY_NODE  (PERSON_INDEX) )   .  DISTANCE_FROM_SOURCE 

<  MINIMALJDISTANCE 
then 

BEST_NEARBY_INDEX  :=  PERSON_INDEX; 
MINIMAL_DISTANCE  := 

PERSON  (NEARBY_NODE   (PERSON_INDEX) )   .  DISTANCE_FROM_SOURCE ; 
end  if ; 
end  loop; 

—  establish  new  THIS_NODE 

THIS_NODE  :=  NEARBY_NODE  (BEST_NEARBY_INDEX) ; 

—  change  THIS_NODE  from  being  NEARBY  to  REACHED 
PERSON  (THIS_NODE)   .  REACHED_STATUS  :=  REACHED; 

—  remove  THIS_NODE  from  NEARBY  list 

NEARBY_NODE  (BEST_NEARBY_INDEX)  :=  NEARBY_NODE  ( LAST_NEARBY_INDEX ) ; 
LAST_NEARBY_INDEX  :=  LAST_NEARBY_INDEX  -  1; 
if  THIS_NODE  =  TARGET_INDEX  then 

SEARCH_STATUS   :=  SUCCEEDED; 
end  if ; 
end  if ; 

end  loop  SEARCH_FOR_TARGET ; 

—  Shortest  path  between  PERSONS  now  established.     Next  task  is 

—  to  translate  path  to  English  description  of  RELATIONSHIP. 

if  SEARCH_STATUS  =  FAILED  then 

put_line  ('  '  &  PERSON  ( TARGE T_INDEX)   .  NAME  &  "  is  not  related  to  "  & 
PERSON  (SOURCE_INDEX)   .  NAME); 
else      —  success  -  parse  path  to  find  and  display  RELATIONSHIP 

RESOLVE_PATH_TO_ENGLISH ; 

COMPUTE_COMMON_GENES   (SOURCE_INDEX,   TARGET_INDEX) ; 
end  if ; 
end  FIND  RELATIONSHIP; 
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  new  compilation-unit  #4:  procedures  under  FIND_RELATIONSHIP 

separate  (RELATE  .  FIND_RELATIONSHIP) 

procedure  PROCESS_ADJACENT_NODE  (BASEJJODE,  NEXT_NODE   :  in  INDEXJTYPE; 

NEXT_BASE_EDGE  :   in  EDGEJTYPE)  is 

—  NEXT_NODE  is  adjacent  to  last-REACHED  node  (=  BASE_NODE) . 

—  if  NEXT_NODE  already  REACHED,  do  nothing. 

—  If  previously  seen,  check  whether  path  thru  BASE_NODE  is 

—  shorter  than  current  path  to  NEXT_NODE,   and  if  so  re-link 

—  next  to  base . 

—  If  not  previously  seen,  link  next  to  base  node. 
WEIGHT_THIS_EDGE,   DISTANCE_THRU_BASE_NODE  :  REAL; 

procedure  LINK_NEXT_NODE_TO_BASE_NODE  is 

—  link  next  to  base  by  re-setting  its  predecessor  index  to 

—  point  to  base,  note  type  of  edge,  and  re-set  distance 

—  as  it  is  through  base  node. 

begin      ~  execution  of  LINK_NEXT_NODE_TO_BASE_NODE 

PERSON  (NEXT_NODE)  .  DISTANCE_FROM_SOURCE  :=  DISTANCE_THRU_BASE_NODE 
PERSON  (NEXTJJODE)   .   PATH_PREDECESSOR  :=  BASE_NODE ; 

PERSON  (NEXT_NODE)   .  EDGE_TO_PREDECESSOR     :=  NEXT_BASE_EDGE ; 

end  LINK_NEXT_NODE_TO_BASE_NODE ; 

begin    —  execution  of  PROCESS_ADJACENT_NODE 

if  PERSON  (NEXT_NODE)   .  REACHED_STATUS  /=  REACHED  then 
if  NEXT_BASE_EDGE  =  SPOUSE  then 

WEIGHT_THIS_EDGE   :=  1.8; 
else 

WEIGHT_THIS_EDGE   :=  1.0; 
end  if ; 

DISTANCE_THRU_BASE_NODE   :=  WEIGHT_THIS_EDGE  + 
PERSON  (BASE_NODE)   .  DISTANCE_FROM_SOURCE ; 
if  PERSON  (NEXTJJODE)   .  REACHED_STATUS  =  NOT_SEEN  then 

PERSON  (NEXT_NODE)   .  REACHED_STATUS  :=  NEARBY; 

LAST_NEARBY_INDEX     :=  LAST_NEARBY_INDEX  +  1; 

NEARBY_NODE  (LAST_NEARBY_INDEX)   :=  NEXT_NODE; 

LINK_NEXT_NODE_TO_BASE_NODE ; 
else      ~  REACHED_STATUS  =  NEARBY 

if  DISTANCE_THRU_BASE_NODE 

<  PERSON  (NEXT_NODE)    .  DISTANCE_FROM_SOURCE 

then 

LINK_NEXr_NODE_TO_BASE_NODE ; 
end  if ; 
end  if ; 
end  if ; 
end  PROCESS  ADJACENT  NODE; 
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separate  (RELATE  .  FIND_RELATIONSHIP ) 
procedure  RESOLVE_PATH_TO_ENGLISH  is 

--  RESOLVE_PATH_TO_ENGLISH  condenses  the  shortest  path  to  a 

—  series  of  RELATIONSHIPS  for  which  there  are  English 

—  descriptions. 

—  Key  persons  are  the  ones  in  the  RELATIONSHIP  path  which  remain 

—  after  the  path  is  condensed. 

type  SIBLINGJIYPE  is  (STEP,  HALF,  FULL); 

type  KEY_PERSON_RECORD     (RELATION_TO_NEXT  :  RELATION_TYPE  :=  PARENT)  is 
record 

PERSON_INDEX       :   INDEXJIYPE  ; 
GENERATION_GAP  :  COUNTER; 
PROXIMITY  :   SIBLINGJTYPE ; 

case  RELATION_TO_NEXT  is 

when  COUSIN  =>  COUSIN_RANK  :  COUNTER; 

when  others  =>  null; 
end  case; 
end  record; 

—  these  variables  are  used  to  generate  KEY_PERSONs 
GENERATION_COUNT  :  COUNTER;  ~ 
THIS_COUSIN_RANK  :  COUNTER; 
THIS_PROXIMITY                     :  SIBLINGJTYPE; 

—  these  variables  are  used  to  condense  the  path 

KEY_PERSON  :  array  (INDEXJTYPE)  of  KEY_PERSON_RECORD ; 

KEY_RELATION,  LATER_KEY_RELATION,  PRIMARY_RELATION, 

NEXT_PRIMARY_RELATION  :  RELATION_TYPE ; 
KEY_INDEX,  LATER_KEY_INDEX,  PRIMARY_INDEX 

:  INDEXJIYPE; 
ANOTHER_ELEMENT_POSSIBLE   :  boolean; 

function    FULL_SIBLING  (INDEXl,   INDEX2  :   in  INDEXJTYPE) 

return  boolean  is 

—  Determines  whether  two  PERSONS  are  full  siblings,  i.e., 

—  have  the  same  two  parents . 
begin 

return 

PERSON  (INDEXl)  .  RELATIVE_IDENTIFIER  (FATHER_IDENT)  /=  NULL_IDENT  and 
PERSON  (INDEXl)  .  RELATIVE_IDENTIFIER  (MOTHER_IDENT)  /=  NULL_IDENT  and 
PERSON  (INDEXl)   .  RELATIVE_IDENTIFIER  (FATHER_IDENT)  = 

PERSON  (INDEX2)   .  RELATIVE_IDENTIFIER  ( FATHER_IDENT)  and 
PERSON  (INDEXl)   .  RELATIVE_IDENTIFIER  (MOTHER_IDENT)  = 

PERSON  (INDEX2)   .  RELATIVE_IDENTIFIER  (MOTHER_IDENT ) ; 
end  FULL  SIBLING; 
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procedure  CONDENSE_KEY_PERSONS  (AT_INDEX  :   in  INDEXJTYFE; 

GAP_SIZE  :   in  COUNTER)  is 

—  CONDENSE_KEY_PERSONS  condenses  superfluous  entries  from  the 

—  KEY_PERSON  array,  starting  at  AT_INDEX. 

RECEIVE_INDEX,   SEND_INDEX  :  INDEXJTYPE; 
begin 

RECEIVE_INDEX  :=  AT_INDEX; 
loop 

RECEIVE_INDEX  :=  RECEIVE_INDEX  +  1; 

SEND_INDEX        :=  RECEIVE_INDEX  +  GAP_SIZE; 

KEY_PERSON  (RECEIVE_INDEX)   :=  KEY_PERSON  (SEND_INDEX) ; 
exit  when  KEY_PERSON  (SEND_INDEX)   .  RELAX ION_TO_NE XT  =  NULL_RELATION; 
end  loop; 
end  CONDENSE_KEY_PERSONS; 

procedure  DISPLAY_RELATION  (FIRST_INDEX,  LAST_INDEX,  PRIMARY_INDEX 

:   in  INDEXJIYPE) 

is  separate; 

begin      —  execution  of  RESOLVE_PATH_TO_ENGLISH 

put_line  ("  Shortest  path  between  identified  persons:  "); 
THIS_NODE     :=  TARGET_INDEX; 
KEY_INDEX     :=  1; 

—  Display  path  and  initialize  KEY_PERSON  array  from  path  elements. 
TRAVERSE_SHORTEST_PATH:  ~ 
while  THIS_NODE  /=  SOURCE_INDEX  loop 

put   ('  '  &  PERSON  (THIS_NODE)   .   NAME  &  "  is  "); 
case  PERSON  (THIS_NODE)   .  EDGE_TO_PREDECESSOR  is 
when  PARENT  => 

put_line  ("parent  of"); 
KEY_PERSON  (KEY_INDEX)  :  = 

(PERSON_INDEX  =>  THIS_NODE, 

GENERATION_GAP      =>  1, 
PROXIMITY  =>  FULL, 

RELATION_TO_NEXT  =>  PARENT); 
when  CHILD  => 

put_line  ("child  of"); 
KEY_PERSON  (KEY_INDEX)  :  = 

(PERSON_INDEX  =>  THIS_NODE, 

GENERATION_GAP      =>  1, 
PROXIMITY  =>  FULL, 

RELATION_TO_NEXT  =>  CHILD); 
when  SPOUSE  => 

put_line  ("spouse  of"); 
KEY_PERSON  (KEY_INDEX)  := 

(PERSON_INDEX  =>  THIS_NODE, 

GENERATION_GAP      =>  0, 
PROXIMITY  =>  FULL, 

RELATION_TO_NEXT  =>  SPOUSE); 
end  case ; 

KEY_INDEX  :=  KEY_INDEX  +  1; 

THIS_NODE  :=  PERSON  (THIS_NODE)   .  PATH_PREDECESSOR; 
end  loop  TRAVERSE  SHORTEST  PATH; 
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put_line('  '  &  PERSON  (THIS_NODE)   .  NAME); 
KEY_PERSON  (KEY_INDEX)  := 

(PERSON_INDEX  =>  THIS_NODE, 

GENERATION_GAP      =>  0, 

PROXIMITY  =>  FULL, 

RELATION_TO_NEXT  =>  NULL_RELATION) ; 
KEY_PERSON  (KEY_INDEX  +1)  := 
(PERSON_INDEX  =>  0, 

GENERATION_GAP      =>  0, 

PROXIMITY  =>  FULL, 

RELATION_TO_NEXT  =>  NULL_RELATION) ; 

—  Resolve  CHILD-PARENT  and  CHILD-SPOUSE-PARENT  relations 

—  to  SIBLING  relations. 
KEY_INDEX  :=  1; 

FIND_SIBLINGS: 

while  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  /=  NULL_RELATION  loop 
if  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  CHILD  then 

LATER_KEY_RELATION  :=  KEY_PERSON  (KEY_INDEX  +  1)  .  RELATION_TO_NEXT ; 
if  LATER_KEY_RELATION  =  PARENT  then 

—  found  either  full  or  half  SIBLINGS 

if  FULL_SIBLING  (KEY_PERSON  (KEY_INDEX)  .  PERSON_INDEX, 

KEY_PERSON  (KEY_INDEX  +  2)   .  PERSON_INDEX) 

then 

THIS_PROXIMITY  :=  FULL; 
else 

THIS_PROXIMITY  :=  HALF; 
end  if ; 

KEY_PERSON  (KEY_INDEX)  :  = 

(PERSON_INDEX  =>  KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX, 

GENERATION_GAP      =>  0, 
PROXIMITY  =>  THIS_PROXIMITY, 

RELATION_TO_NEXT  =>  SIBLING); 
CONDENSE_KEY_PERSONS  (KEY_INDEX,  1); 
elsif  (LATER_KEY_RELATION  =  SPOUSE)  and 

(KEY_PERSON  (KEY_INDEX  +  2)   .  RELATION_TO_NEXT  =  PARENT) 
then  —  found  step-SIBLINGs 
KEY_PERSON  (KEY_INDEX)  :  = 

(PERSON_INDEX  =>  KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX, 

GENERATION_GAP      =>  0, 
PROXIMITY  =>  STEP, 

RELATION_TO_NEXT  =>  SIBLING); 
CONDENSE_KEY_PERSONS  (KEY_INDEX,  2); 
end  if;     ~  LATER_KEY_RELATION  =  PARENT 
end  if;       ~  RELATION_TO_NEXT  =  CHILD 
KEY_INDEX  :=  KEY_INDEX  +  1; 
end  loop  FIND_SIBLINGS ; 
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—  Resolve  CHILD-CHILD-. . .  and  PARE NT -PARE NT-. . .  relations  to 
— -  direct  descendant  or  ancestor  relations. 
KEY_INDEX  :=  1; 
FIND_ANCESTORS_OR_DESCENDANTS : 

while  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  /=  NULL_RELATION  loop 
if  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  CHILD)  or 

(KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  PARENT) 
then 

LATER_KEY_INDEX  :=  KEY_INDEX  +  1; 

while  KEY_PERSON  (LATER_KEY_INDEX)   .  RELATION_TO_NEXr  = 

KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  loop 

LATER_KEY_INDEX  :=  LATER_KEY_INDEX  +  1; 
end  loop; 

GENERATION_COUNT  :=  LATER_KEY_INDEX  -  KEY_INDEX; 

if  GENERATION_COUNT  >  1  then      —  compress  generations 

KEY_PERSON  (KEY_INDEX)   .  GENERATION_GAP  :=  GENERATION_COUNT ; 

CONDENSE_KEY_PERSONS  (KEY_INDEX,   GENERATIONjCOUNT  -  1); 
end  if; 

end  if;       ~  if  RELATION_TO_NEXT  =  CHILD  or  PARENT 
KEY_INDEX  :=  KEY_INDEX  +  1; 
end  loop  FIND  ANCESTORS  OR  DESCENDANTS; 
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—  Resolve  CHILD-SIBLING-PARENT  to  COUSIN, 
CHILD-SIBLING  to  NEPHEW, 

SIBLING-PARENT  to  UNCLE. 

KEY_INDEX  :=  1; 
F  IND_C  OUS  INS_NE  PHEWS_UNCLE  S : 

while  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  /=  NULL_RELATION  loop 
LATER_KEY_RELATION  :=  KEY_PERSON  (KEY_INDEX  +  1)   .  RELATION_TO_NEXT ; 
if  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  CHILD)  and 

(LATER_KEY_RELATION  =  SIBLING) 
then      ~  COUSIN  or  NEPHEW 

if  KEY_PERSON  (KEY_INDEX  +  2)   .  RELATION_TO_NEXT  =  PARENT  then 
—  found  COUSIN 

if  KEYJPERSON  (KEY_INDEX)  .   GENERATION_GAP  < 

KEY_PERSON  (KEY_INDEX  +  2)   .  GENERATION_GAP 
then 

THIS_COUSIN_RANK  := 

KEY_PERSON  (KEY_INDEX)   .  GENERATION_GAP; 

else 

THIS_COUSIN_RANK  := 

KEY_PERSON  (KEY_INDEX  +  2)   .  GENERATION_GAP; 

end  if ; 

KEY_PERSON  (KEY_INDEX)   :  = 

(PERSON_INDEX  =>  KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX, 

GENERATION_GAP  => 

abs  (KEY_PERSON  (KEY_INDEX)  .  GENERATION_GAP  - 

KEY_PERSON  (KEY_INDEX  +  2)   .   GENERATION_GAP) , 
PROXIMITY  =>  KEY_PERSON  (KEY_INDEX  +  1)   .  PROXIMITY, 

RELATION_TO_NEXT  =>  COUSIN, 
COUSINJRANK  =>  THIS_COUSIN_RANK) ; 

CONDENSE_KEY_PERSONS  (KEY_INDEX,  2); 
else    —  found  NEPHEW 

KEY_PERSON  (KEY_INDEX)  :  = 

(PERSON_INDEX  =>  KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX, 

GENERATION_GAP      =>  KEY_PERSON  (KEY_INDEX)   .  GENERATION_GAP, 
PROXIMITY  =>  KEY_PERSON  (KEY_INDEX  +  1)   .  PROXIMITY, 

RELATION_TO_NEXT  =>  NEPHEW); 
CONDENSE_KEY_PERSONS  (KEY_INDEX,  1); 
end  if ; 

elsif  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  SIBLING  and 

LATER_KEY_RELATION  =  PARENT 
then      —  found  UNCLE 

KEY_PERSON  (KEY_INDEX)  :  = 

(PERSON_INDEX  =>  KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX, 

GENERATION_GAP  =>  KEY_PERSON  (KEY_INDEX  +  1)  .  GENERATION_GAP, 
PROXIMITY  =>  KEY_PERSON  (KEY_INDEX)   .  PROXIMITY, 

RELATION_TO_NEXT  =>  UNCLE); 
CONDENSE_KEY_PERSONS  (KEY_INDEX,  1); 
end  if ; 

KEY_INDEX  :=  KEY_INDEX  +  1; 
end  loop  FIND  COUSINS  NEPHEWS  UNCLES; 
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—  Loop  below  will  pick  out  valid  adjacent  strings  of  elements 

—  to  be  displayed.     KEY_INDEX  points  to  first  element, 

—  LATER_KEY_INDEX  to  laFt  element,  and  PRIMARY_INDEX  to  the 

—  element  which  determines  the  primary  English  word  to  be  used. 

—  Associativity  of  adjacent  elements  in  condensed  table 

—  is  based  on  English  usage. 
KEY_INDEX  :=  1; 

put_line  ("  Condensed  path:"); 
CONSOLIDATE_AD JACENT_PERSONS : 

while  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  /=  NULL_RELATION  loop 

KEY_RELATION        :=  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT ; 

LATER_KEY_INDEX  :=KEY_INDEX; 

PRIMARY_INDEX       :=  KEY_INDEX; 

if  KEYJPERSON  (KEY_INDEX  +  1)   .  RELATION_TO_NEXT  /=  NULL_RELATION  then 
'  —  seek  multi-element  combination 

■   '    ANOTHER_ELEMENT_POSSIBLE   :=  true; 
if  KEY_RELATION  =  SPOUSE  then 

LATER_KEY_INDEX  :=  LATER_KEY_INDEX  +  1; 
PRIMARY_INDEX      :=  LATER_KEY_INDEX; 

if  (KEY_PERSON  (LATER_KEY_INDEX)   .  RELATION_TO_NEXT  =  SIBLING)  or 

(KEY_PERSON  (LATER_KEY_INDEX)   .  RELATION_TO_NEXT  =  COUSIN) 
then      —  Nothing  can  follow  SPOUSE-SIBLING  or  SPOUSE-COUSIN 

ANOTHER_ELEMENT_POSSIBLE  :=  false; 
end  if ; 
end  if ; 

—  PRIMARY_INDEX  is  now  correctly  set.     Next  if-statement 

—  determines  if  a  following  SPOUSE  relation  should  be 

—  appended  to  this  combination  or  left  for  the  next 
• —  combination. 

if  ANOTHER_ELEMENT_POSSIBLE  and 

(KEY_PERSON  (PRIMARY_INDEX  +  1)   .  RELATION_TO_NEXT  =  SPOUSE) 

—  Only  a  SPOUSE  can  follow  a  Primary 
then 

—  check  primary  preceding  and  following  SPOUSE. 
PRIMARY_RELATION  :  = 

KEY_PERSON  (PRIMARY_INDEX)  .  RELATION_TO_NEXT ; 

NEXT_PRIMARY_RELATION  :  = 

KEY_PERSON  (PRIMARY_INDEX  +  2)   .  RELATION_TO_NEXT ; 
if  (NEXT_PRIMARY_RELATION  =  NEPHEW  or 
NEXT_PRIMARY_RELATION  =  COUSIN  or 
NEXT_PRIMARY_RELATION  =  NULL_RELATION) 
or  (PRIMARY_RELATION  =  NEPHEW) 
or  (   (PRIMARY_RELATION  =  SIBLING  or 
PRIMARY_RELATION  =  PARENT) 
and  NEXT_PRIMARY_RELATION  /=  UNCLE  ) 
then    —  append  following  SPOUSE  with  this  combination. 

LATER_KEY_INDEX  :=  LATER_KEY_INDEX  +  1; 
end  if ; 
end  if ; 

end  if;     —  multi-element  combination 

DISPLAY_RELATION  (KEY_INDEX,  LATER_KEY_INDEX,   PRIMARY_INDEX) ; 
KEY_INDEX  :=  LATER_KEY_INDEX  +  1; 
end  loop  CONSOLIDATE_ADJACENT_PERSONS ; 

put_line  ('  '  &  PERSON  (KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX)   .  NAME); 
end;       —  RESOLVE  PATH  TO  ENGLISH 


  new  compilation-unit  #5:   procedures  under  RESOLVE_PATH_TO_ENGLISH 

separate  (RELATE  .  FIND_RELATIONSHIP  .  RESOLVE_PATH_TO_ENGLISH) 
procedure  DISPLAY_RELATION  (FIRST_INDEX,  LAST_INDEX,  PRIMARY_INDEX 

:  in  INDEX_TYPE)  is 

—  DISPLAY_RELATION  takes  1,   2,   or  3  adjacent  elements  in  the 

—  condensed  table  and  generates  the  English  description  of 

—  the  relation  between  the  first  and  last  +  1  elements. 

INLAW  :  boolean; 

THIS_PROXIMITY        :   SIBLINGJTYPE ; 
THIS_GENDER  :  GENDERJTYPE ; 

FIRST_RELATION,  LAST_RELATION,  PRIMARY_RELATION 

:  RELATION_TYPE ; 
THIS_GENERATION_GAP ,   THIS_C OUS IN_RANK 

:  COUNTER; 

—  need  to  instantiate  package  to  display  integer  values 
package  COUNTER_IO  is 

new  integer  io  (COUNTER); 
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begin      —  execution  of  DISPLAY_RELATION 

FIRST_RELATION  :=  KEY_PERSON  (FIRST_INDEX)  .  RELATION_TO_NEXT ; 
LAST_RELATION  :=  KEY_PERSON  (LAST_INDEX)         .  RELATION_TO_NEXT ; 

PRIMARY_RELATION     :=  KEY_PERSON  (PRIMARY_INDEX)   .  RELATION_TO_NEXT ; 

—  set  THIS_PROXIMITY 

if  ((PRIMARY_RELATION  =  PARENT)  and  (FIRST_RELATION  =  SPOUSE))  or 

((PRIMARY_RELATION  =  CHILD)     and  (LAST_RELATION    =  SPOUSE)) 
then 

THIS_PROXIMITY  :=  STEP; 
elsif  PRIMARY_RELATION  =  SIBLING  or 
PRIMARY_RELATION  =  UNCLE  or 
PRIMARY_RELATION  =  NEPHEW  or 
PRIMARY_RELATION  =  COUSIN 

then 

THISJPROXIMITY  :=  KEY_PERSON  (PRIMARY_INDEX)   .  PROXIMITY; 
else 

THIS_PROXIMITY  :=  FULL; 
end  if ; 

—  set  THIS_GENERATION_GAP 

if  PRIMARY_RELATION  =  PARENT  or 

PRIMARY_RELATION  =  CHILD  or 

PRIMARY_RELATION  =  UNCLE  or 

PRIMARY_RELATION  =  NEPHEW  or 

PRIMARY_RELATION  =  COUSIN 
then 

THIS_GENERATION_GAP  :=  KEY_PERSON  (PRIMARY_INDEX)   .  GENERATION_GAP; 
else 

THIS_GENERATION_GAP  :=  0; 
end  if ; 

—  set  INLAW 
INLAW  :=  false; 

if  (FIRST_RELATION  =  SPOUSE)  and 
(PRIMARY_RELATION  =  SIBLING  or 
PRIMARY_RELATION  =  CHILD  or 
PRIMARY_RELATION  =  NEPHEW  or 
PRIMARY_RELATION  =  COUSIN) 

then 

INLAW  :=  true; 
elsif  (LAST_RELATION        =  SPOUSE)  and 
(PRIMARY_RELATION  =  SIBLING  or 
PRIMARY_RELATION  =  PARENT  or 
PRIMARY_RELATION  =  UNCLE  or 
PRIMARY_RELATION  =  COUSIN) 

then 

INLAW  :=  true; 
end  if ; 

—  set  THIS_COUSIN_RANK 

if  PRIMARY_RELATION  =  COUSIN  then 

THIS_COUSIN_RANK  :=  KEYJPERSON  (PRIMARY_INDEX)   .  COUSIN_RANK; 
end  if ; 
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—  parameters  are  set  -  now  generate  display. 

put  ("  "  &  PERSON  (KEY_PERSON  (FIRST_INDEX)   .  PERSON_INDEX)   .  NAME  & 
"  is  "); 

if  PRIMARY_RELATION  =  PARENT  or 

PRIMARY_RELATION  =  CHILD  or 

PRIMARY_RELATION  =  UNCLE  or 

PRIMARY_RELATION  =  NEPHEW 
then 

—  display  generation-qualifier 
if  THIS_GENERATION_GAP  >=  3  then 
put  ("great"); 

if  THIS_GENERATION_GAP  >  3  then 
put  ("*"); 

COUNTER_IO  .  put  (THIS_GENERATION_GAP  -  2,  width  =>  1); 
end  if ; 
put  ("-"); 
end  if ; 

if  THIS_GENERATION_GAP  >=  2  then 

put  ("grand-"); 
end  if ; 

elsif  (PRIMARY_RELATION  =  COUSIN)  and  then  (THIS_COUSIN_RANK  >  1)  then 
COUNTER_IO  .   put  (THIS_COUSIN_RANK,  width  =>  1 ) ; 
case  THIS_COUSIN_RANK  mod  10  is 
when  1  =>  put  ("st  "); 

when  2  =>  put  ("nd  "); 

when  3  =>  put  ("rd  "); 

when  others  =>  put  ("th  "); 
end  case ; 
end  if ; 

if  THIS_PROXIMITY  =  STEP  then 

put  ("step-"); 
elsif  THIS_PROXIMITY  =  HALF  then 

put  ("half-"); 
end  if ; 
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THIS_GENDER  :=  PERSON  (KEY_PERSON  (FIRST_INDEX) 
case  PRIMARY_RELATION  is 
when  PARENT 


when  CHILD 


PERSON  INDEX)   .  GENDER; 


when  SPOUSE 


when  UNCLE 


when  NEPHEW 


.  when  COUSIN 
when  others 
end  case; 


if  THIS  GENDER  = 

MALE 

then 

put  ( 

'"father"); 

else 

put  ( 

' "mother" ) ; 

end  if ; 

if  THIS_GENDER  = 

MALE 

then 

put  ( 

'  "son") ; 

else 

put  ( 

[ "daughter" ) ; 

end  if ; 

if  THIS  GENDER  = 

MALE 

then 

put  ( 

[ "husband" ) ; 

else 

put  ( 

[ "wife" ) ; 

end  if ; 

if  THIS_GENDER  = 

MALE 

then 

put  < 

[ "brother" ) ; 

else 

put  ( 

^"sister"); 

end  if ; 

if  THIS_GENDER  = 

MALE 

then 

put  ( 

[ "uncle" ) ; 

else 

put  ( 

[ "aunt" ) ; 

end  if ; 

if  THIS  GENDER  = 

MALE 

then 

put  ( 

[ "nephew" ) ; 

else 

put  ( 

[ "niece" ) ; 

end  if ; 

put  ("cousin"); 

put  ("null"); 

if  INLAW  then 

put  ("-in-law"); 
end  if ; 


if  (PRIMARY_RELATION  =  COUSIN)  and  (THIS_GENERATION_GAP  >  0)  then 
if  THIS_GENERATION_GAP  >  1  then 
put  ("  "); 

COUNTER_IO  ,  put  (THIS_GENERATION_GAP,  width  =>  1); 
put  ("  times  removed"); 
else 

put  ("  once  removed"); 
end  if ; 
end  if; 

put_line  ("  of"); 
end  DISPLAY  RELATION; 


  new  compilation-unit  #5:  procedures  under  FIND_RELATIONSHIP 

eparate  (RELATE  .  FIND_RELATIONSHIP) 

rocedure  COMPUTE_COMMON_GENES  (INDEXl,  INDEX2  :   in  INDEX_TYPE)  i 
~  COMPUTE_COMMON_GENES  assumes  that  each  ancestor  contributes 

—  half  of  the  genetic  material  to  a  PERSON.     It  finds  common 

—  ancestors  between  two  PERSONS  and  computes  the  expected 

—  value  of  the  PROPORTION  of  common  material. 

COMMON_PROPORTION  :  REAL; 

package  REAL_IO  is 
new  FLOAT_rO  (REAL); 

procedure  ZERO_PROPORTION  (ZERO_INDEX  :   in  INDEXJTYPE)  is 

—  ZERO_PRO PORTION  recursively  seeks  out  all  ancestors  and 

—  zeros  them  out. 

THIS_NEIGHBOR  :  NEIGHBOR_POINTER ; 
begin 

PERSON  (ZERO_INDEX)   .  DESCENDANT_GENES   :=  0.0; 
THIS_NEIGHBOR  :=  PERSON  (ZERO_INDEX)    .  NEIGHBOR_LIST_HEADER ; 
while  THIS_NEIGHBOR  /=  null  loop 

if  THIS_NEIGHBOR  .   NEIGHBOR_EDGE  =  PARENT  then 

ZERO_PROPORTION  (THIS_NEIGHBOR  .  NEIGHBOR_INDEX) ; 

end  if ; 

THIS_NEIGHBOR  :=  THIS_NEIGHBOR  .  NEXTJJEIGHBOR; 
end  loop; 
end  ZERO_PR0P0RTION; 

procedure  MARK_PROPORTION  (MARKER  :  in  IDENTIFIER_TYPE ; 

PROPORTION       :   in  REAL; 
MARKED_INDEX  :   in  INDEXJTYPE)  is 

—  MARK_PROPORTION  recursively  seeks  out  all  ancestors  and 

—  markJ  them  with  the  sender's  PROPORTION  of  shared 

—  genetic  material.     This  PROPORTION  is  diluted  by  one-half 

—  for  each  generation. 

THIS_NEIGHBOR  :  NEIGHBOR_POINTER; 
begin 

PERSON  (MARKED_INDEX)   .  DESCENDANT_IDENTIFIER  :=  MARKER; 
PERSON  (MARKED_INDEX)   .   DESCENDANT_GENES  := 

PERSON  (MARKED_INDEX)   .  DESCENDANT_GENES  +  PROPORTION; 
THIS_NEIGHBOR  :=  PERSON  (MARKED_INDEX)   .  NEIGHBOR_LIST_HEADER 
while  THIS_NEIGHBOR  /=  null  loop 

if  THIS_NEIGHBOR  .  NEIGHBOR_EDGE  =  PARENT  then 
MARK_PROPORTION  (MARKER,   PROPORTION  /  2.0, 

THIS_NEIGHBOR  .   NEIGHBOR_INDEX) ; 

end  if ; 

THISJJEIGHBOR  :=  THIS_NEIGHBOR  .  NEXT_NEIGHBOR; 
end  loop; 
end  MARK  PROPORTION; 
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procedure  CHECK_COMMON_PROPORTION 

(COMMON_PRO PORTION  :   in  out  REAL; 
MATCH_IDENTIFIER     :  in  IDENTIFIERJCYPE ; 

PROPORTION  :  in  REAL; 

ALREADYJCOUNTED       :  in  REAL; 
CHECK_INDEX  :   in  INDEXJTYPE)  is 

—  CHECK_COMMON_PROPORTION  searches  all  the  ancestors  of 

—  CHECK  INDEX  to  see  if  any  have  been  marked,  and  if  so 

—  adds  the  appropriate  amount  to  COMMON_PROPORTION. 


THIS_NEIGHBOR  :  NEIGHBOR_POINTER; 

THIS  CONTRIBUTION  :  REAL; 


beg  in 

if  PERSON  (CHECK_INDEX)   .  DESCENDANT_IDENTIFIER  =  MATCH_IDENTIFIER  then 

—  Increment  COMMON_PROPORTION  by  the  contribution  of 

—  this  common  ancestor,  but  discount  for  the  contribution 

—  of  less  remote  ancestors  already  counted. 

THIS_CONTRIBUTION  :=  PERSON  (CHECK_INDEX)   .  DESCENDANT_GENES 

*  PROPORTION; 
COMMON_PRO PORTION  :=  COMMON_PROPORTION 
+  THIS_CONTRIBUTION  -  ALREADY_COUNTED; 

else 

THIS_CONTRIBUTION  :=  0.0; 
end  if ; 

THISJJEIGHBOR  :=  PERSON  (CHECK_INDEX)   .  NEIGHBOR_LIST_HEADER; 
while  THIS_NEIGHBOR  /=  null  loop 

if  THISJJEIGHBOR  .  NEIGHBOR_EDGE  =  PARENT  then 
CHECK_COMMON_PRO PORTION  (COMMON_PROPORTION, 
MATCH_IDENTIFIER,   PROPORTION  /  2.0, 
THIS_CONTRIBUTION  /  4.0, 
THIS_NEIGHBOR  .  NEIGHBOR_INDEX) ; 

end  if; 

THISJJEIGHBOR  :=  THISJJEIGHBOR  .  NEXTJJEIGHBOR; 
end  loop; 
end  CHE CK_COMMONJ>RO PORTION; 

begin      —  COMPUTE  j:OMMON_GENES 

—  First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 

—  because  there  might  be  two  paths  to  an  ancestor. 
ZERO_PROPORTION  (INDEXl); 

—  now  mark  with  shared  PROPORTION 

MARKJ'ROPORTION  (PERSON  (INDEXl)   .  IDENTIFIER,   1.0,  INDEXl); 
COMMON_PROPORTION  :=  0.0; 

CHECK_COMMON_PRO PORTION  (COMMONJ>RO PORTION, 

PERSON  (INDEXl)   .   IDENTIFIER,   1.0,   0.0,  INDEX2); 
put  ("  Proportion  of  common  genetic  material  =  "); 
REAL_IO  .  put  (COMMON_PRO PORTION,   fore  =>  1,  aft  =>  5,  exp  =>  3 ) ; 
put_line  ("  "); 
end  COMPUTE  COMMON  GENES; 
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3.0  BASIC 

Because  of  the  unavailability  of  a  standard  implementation,  the  BASIC  program 
could  not  be  tested  directly.  However,  a  syntactically  non-standard  version, 
which  is  believed  to  be  logically  equivalent,  was  tested. 

10000  !    program-unit  number  1   

10010  ! 

10020  program  RELATE 
10030  ! 

10040  !     declare  subs  to  be  used  by  this  program-unit 
10050  ! 

10060  declare  external  sub  FIND_RELATIONSHIP 

10070  declare  sub  LINKJIELATIVES",  LINK_0NE_WAY,  PROMPT_AND_READ 
10080  declare  sub  CHECK_REQUEST,  SEARCH_FOR_REQUESTED_PERSONS 
10090  ! 

10100  option  base  1 
10110  ! 

10120  !     Define  global  objects 
10130  ! 

10140  data  300 

10150  read  MAX_PERS0NS 

10160  ! 

10170  data     1,  2  !  for  truth  values 

10180  read     TRUE,  FALSE 
10190  ! 

10200  !     each  PERSON'S  record  in  the  file  identifies  at  most  three 
10210  !     others  directly  related:  father,  mother,  and  spouse 
10220  data  1,  2,  3 

10230  read  FATHER_IDENT,  M0THER_IDENT,  SP0USE_IDENT 
10240  ! 

10250  data  M,  F 

10260  read  MALE$,  FEMALE  $ 

10270  ! 

10280  data  000 

10290  read  NULL_IDENT$ 

10300  ! 

10310  data  1,  2,  3,  4,  5,  6,  7,  8 

10320  read  PARENT,  CHILD,  SPOUSE,   SIBLING,  UNCLE,  NEPHEW 
10325  read  COUSIN,  NULL_RELATI0N 
10330  ! 

10340  !     A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 
10350  !     is  immediately  adjacent  to  those  reached,  or  farther  away. 
10360  data  1,  2,  3 

10370  read  REACHED,  NEARBY,  N0T_SEEN 
10380  ! 
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10390 
10400 
10410 
10420 
10430 
10440 
10450 
10460 
10470 
10480 
10490 
10500 
10505 
10510 
10520 
10530 
10540 
10550 
10560 
10570 
10580 
10590 
10600 
10610 
10620 
10630 


I 

dim 
I 
! 

dim 

I 

I 

dim 

dim 

! 

I 

dim 

dim 
I 

I 

dim 

! 


The  following  data  arrays  are  the  central  repository  of  information 
about  inter-relationships.     All  relationships  are  captured  in  the 
directed  graph  of  which  each  record  is  a  node. 

static  information  -  filled  from  PEOPLE  file: 
NAME$  (300),   IDENTIFIER$  (300),   GENDER$  (300) 


IDENTIFIER$s  of  immediate  relatives 
RELATIVE  IDENTIFIER$  (300,3) 


father,  mother,  spouse 


pointers  to  immediate  neighbors  in  graph 
NEIGHBORJCOUNT  (300) 

NEIGHBOR_INDEX  (300,20),  NEIGHB0R_EDGE  (300,20) 

data  used  when  traversing  graph  to  resolve  user  request: 
DISTANCE_FR0M_S0URCE  (300),   PATH_PREDECESSOR  (300) 
EDGE_T0_PREDECESS0R     (300),  REACHED_STATUS  (300) 

data  used  to  compute  common  genetic  material 
DESCENDANT  IDENTIFIER$  (300),  DESCENDANT  GENES  (300) 


stop.  Request  OK 
REQUEST  TO  STOP$,  REQUEST  0K$ 


data 

read 
! 

!  end  initialization 
I 


I 
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10640  !  begin  main  line  of  execution 

10650  ! 

10660  open  #1:  name  "PE0PLE.DAT",  access  input,  rectype  native,  & 

&  organization  sequential 

10670  ! 

10680  !     This  loop  reads  in  the  PEOPLE  file  and  constructs  the  person 

10690  !     array  from  it  (one  person  =  one  set  of  array  entries). 

10700  !     As  records  are  read  in,  links  are  constructed  to  represent  the 

10710  !     PARENT -CHILD  or  SPOUSE  RELATIONSHIP.     The  array  then  implements 

10720  !     a  directed  graph  which  is  used  to  satisfy  subsequent  user 

10730  !     requests.     The  file  is  assumed  to  be  correct  -  no  validation 

10740  !     is  performed  on  it. 

10750  ! 

10760  for  CURRENT  =  1  to  MAX_PERS0NS 

10770  read  #1,  if  missing  then  exit  for,  & 

&  with  "string*20,  string*3,  string*l,  3  of  string*3":  & 

&  NAME$  (CURRENT),  IDENTIFIER$  (CURRENT),  GENDER$  (CURRENT),  & 

&  RELATIVE_IDENTIFIER$  (CURRENT,  FATHER_IDENT) ,  & 

&  RELATIVE_IDENTIFIER$  (CURRENT,  M0THER_IDENT) ,  & 

&  RELATIVE_IDENTIFIER$  (CURRENT,   SPOUSE_IDENT ) 

10780  let  NAME$  (CURRENT)  =  rtrim$  (NAME$  (CURRENT)) 

10790  !     Location  of  adjacent  persons  as  yet  undetermined 

10800  let  NEIGHB0R_C0UNT  (CURRENT)  =  0 

10810  !     Descendants  as  yet  undetermined 

10820  let  DESCENDANT_IDENTIFIER$  (CURRENT)  =  NULL_IDENT$ 

10830  let  CURRENT_IDENT$  =  IDENTIFIER$  (CURRENT) 

10840  !     Compare  this  PERSON  against  all  previously  entered  PERSONS 

10850  !     to  search  for  RELATIONSHIPS. 

10860  for  PREVIOUS  =  1  to  CURRENT  -  1 

10870  let  PREVIOUS_IDENT$  =  IDENTIFIER$  (PREVIOUS) 

10880  !     Search  for  father,  mother,  or  spouse  relationship  in 

10890  !     either  direction  between  this  and  PREVIOUS  person. 

10900  !     Assume  at  most  one  RELATIONSHIP  exists. 

10910  for  RELATIONSHIP  =  FATHER_IDENT  to  SP0USE_IDENT 

10920  if  RELATIVE_IDENTIFIER$  (CURRENT,  RELATIONSHIP)  & 

&  =  PREVIOUS_IDENT$  then 

10930  call  LINK_RELATIVES  (CURRENT,  RELATIONSHIP,  PREVIOUS) 

10940  exit  for 

10950  elseif  RELATIVE_IDENTIFIER$  (PREVIOUS,  RELATIONSHIP)  & 

&  =  CURRENT_IDENT$  then 

10960  call  LINK_RELATIVES  (PREVIOUS,  RELATIONSHIP,  CURRENT) 

10970  exit  for 

10980  end  if 

10990  next  RELATIONSHIP 

11000  next  PREVIOUS 


11010  next  CURRENT 

11020  let  NUMBER_OF_PERSONS  =  CURRENT  -  1 
11030  close  #1 
11040  ! 

11050  !     Person  arrays  are  now  loaded  and  edges  between  immediate  relatives 
11060  !     (PARENT -CHILD  or  SPOUSE -SPOUSE)  are  established. 
11070  ! 
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11080  !     Do-loop  accepts  requests  and  finds  relationship  (if  any) 
11090  !     between  pairs  of  PERSONS. 
11110  do 


11120  call  PROMPT_AND_READ 

11130  if  REQUEST_BUFFER$  =  REQUEST_T0_ST0P$  then  exit  do 

11140  call  CHECK_REQUEST  (ERR0R_MESSAGE$,   PERS0N1_IDENT$,   PERS0N2_IDENT$ ) 

11150  ! 

11160  !        Syntax  check  of  request  completed.     Now  either  display  error 

11170  !        message  or  search  for  the  two  PERSONS. 

11180  ! 

11190  if  ERR0R_MESSAGE$  =  REQUEST_0K$  then 

11200  !     request  syntactically  correct 

11210  call  SEARCH_F0R_REQUESTED_PERS0NS(PERS0N1_IDENT$,   PERS0N2_IDENT$,  & 

&  PERS0N1_INDEX,     PERS0N2_INDEX,  & 

&  PERS0N1_F0UND,  PERS0N2_F0UND) 

11220  if  PERS0N1_F0UND  =  1  and  PERS0N2_F0UND  =  1  then 

11230  !     Exactly  one  match  for  each  PERSON  -  proceed  to 

112A0  !     determine  RELATIONSHIP,  if  any. 

11250  if  PERS0N1_INDEX  =  PERS0N2_INDEX  then 

11260  print  "  ";  NAME$  (PERS0N1_INDEX) ;   "  is  identical  to  "; 

11270  if  GENDER$  ( PERSON 1_INDEX)  =  MALE$  then 

11280  print  "himself." 

11290  else 

11300  print  "herself." 

11310  end  if 

11320  else 

11330  call  FIND_RELATIONSHIP  & 

&  (PERS0N1_INDEX,   PERS0N2_INDEX,  NUMBER_0F_PERS0NS,  & 

&  NAME$,   IDENTIFIER$,   GENDER$,  RELATIVE_IDENTIFIER$,  & 

&  NEIGHB0R_C0UNT,  NEIGHBOR_INDEX,  NEIGHB0R_EDGE ,  & 

&  DISTANCE_FR0M_S0URCE,   PATH_PREDECESSOR,  & 

&  EDGE_T0_PREDECESS0R  ,  REACHED_STATUS ,  & 

&  DESCENDANT_IDENTIFIER$,   DESCENDANT_GENES ) 

11340  end  if 

11350  else       !     either  not  found  or  more  than  one  found 

11360  if  PERS0N1_F0UND  =  0  then 

11370  print  "  First  person  not  found." 

11380  elseif  PERS0N1_F0UND  >  1  then 

11390  print  "  Duplicate  names  for  first  person  -"; 

11400  print  "  use  numeric  identifier." 

11410  end  if 

11420  if  PERS0N2_F0UND  =  0  then 

11430  print  "  Second  person  not  found." 

11440  elseif  PERS0N2_F0UND  >  1  then 

11450  print  "  Duplicate  names  for  second  person  -"; 

11460  print  "  use  numeric  identifier." 

11470  end  if 

11480  end  if 

11490  else 

11500  print  "  Incorrect  request  format:  ";  ERR0R_MESSAGE$ 

11510  end  if 


11520  loop 

11530  print  "  End  of  relation-finder." 
11540  stop 
11550  ! 

11560  !  end  of  main  line  of  execution;  internal  subs  follow 
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11570  ! 

11580  sub  LINK_RELATIVES  (FROM_INDEX,   RELATIONSHIP,  TO_INDEX) 

11590  !       establishes  cross-indexing  between  immediately  related  PERSONS. 

11600  ! 

11610  if  RELATIONSHIP  =  SPOUSE_IDENT  then 

11620        call  LINK_ONE_WAY  (FROM_INDEX,  SPOUSE,  TO_INDEX) 

11630         call  LINK_ONE_WAY  (TO_INDEX,       SPOUSE,  FROM_INDEX) 

11640  else     !     RELATIONSHIP  is  father  or  mother 

11650        call  LINK_ONE_WAY  (FROM_INDEX,   PARENT,  TO_INDEX) 

11660         call  LINK_ONE_WAY  (TO_INDEX,       CHILD,  FROM_INDEX) 

11670  end  if 

11680  end  sub 

11690  ! 

11700  sub  LINK_ONE_WAY  (FROM_INDEX,   THIS_EDGE,  TO_INDEX) 

11710  !       Establishes  the  neighbor  entries  from  one  person  to  another 

11720  ! 

11730  let  NEXT_NEIGHBOR  =  NEIGHBOR_COUNT  (FROM_INDEX)  +  1 

11 740  let  NEIGHBOR_COUNT  (FROM_INDEX)  =  NEXT_NEIGHBOR 

11750  let  NEIGHBOR_INDEX  (FROM_INDEX,   NEXT_NEIGHBOR)  =  TO_INDEX 

11760  let  NEIGHBOR_EDGE     (FROM_INDEX,  NEXT_NEIGHBOR)  =  THIS_EDGE 

11770  end  sub 

11780  ! 

11790  sub  PROMPT_AND_READ 

11800  !     Issues  prompt  for  user-request,  reads  in  request, 
11810  !     blank-fills  buffer,  and  skips  to  next  line  of  input. 
11820  ! 
11830  print 

11840  print  "  " 

11850  print  "  Enter  two  person-identifiers  (name  or  number)," 
11860  print  "  separated  by  semicolon.  Enter  ""stop""  to  stop." 
11870  line  input  REQUEST_BUFFER$ 
11880  end  sub 
11890  ! 

11900  sub  CHECK_REQUEST  (REQUEST_STATUS $ ,   PERS0N1_IDENT$ ,  PERS0N2_IDENT$) 

11910  !       Performs  syntactic  check  on  request  in  buffer 

11920  !      and  fills  in  identifiers  of  the  two  requested  persons. 

11930  ! 

11940  let  SEMICOLON_LOCATION  =  pos  (REQUEST_BUFFER$ ,  ";") 
11950  let  PERS0N1_IDENT$  =  ltrim$  (rtrim$  & 
&  (REQUEST_BUFFER$  (1   :   SEMICOLONJLOCATION  -  1))) 

11960  let  PERS0N2_IDENT$  =  ltrim$  (rtrim$  & 

&  (REQUEST_BUFFER$  (SEMICOLON_LOCATION  +  1  :  len  (REQUEST_BUFFER$ ) ) ) ) 

11970  if  SEMICOLON  LOCATION     =  0  or  pos  (PERS0N2  IDENT$,   ";")  <>  0  then 


11980        let  REQUEST_STATUS$ 
11990  el self  PERSON 1_I DENT $ 
12000        let  REQUEST_STATUS$ 
12010  elseif  PERS0N2  IDENT$ 


must  be  exactly  one  semicolon." 
then 

null  field  preceding  semicolon.' 
"  then 


12020  let  REQUEST_STATUS$  =  "null  field  following  semicolon.' 
12030  else 

12040        let  REQUEST_STATUS$  =  REQUEST_OK$ 
12050  end  if 
12060  end  sub 
12070  ! 
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12080  sub  SEARCH  FOR  REQUESTED_PERSONS  (PERSON 1_IDENT$,   PERS0N2  IDENT$,  & 


&  PERS0N1_INDEX,     PERS0N2_INDEX,  & 

&  PERS0N1_F0UND,  PERS0N2_F0UND) 

12090  !  SEARCH_FOR_REQUESTED_PERSONS  scans  through  the  PERSON  array, 

12100  !  looking  for  the  two  requested  PERSONS.     Match  may  be  by  NAME 

12110  !  or  unique  IDENTIFIER-number 

12120  ! 


12130  let  PERSON 1_F0UND  =  0 

12140  let  PERS0N2_F0UND  =  0 

12150  let  PERS0N1_INDEX  =  0 

12160  let  PERS0N2_INDEX  =  0 

12170  for  CURRENT  =  1  to  NUMBER_OF_PERSONS 

12180        !     allow  identification  by  name  or  identifier 

12190        if  IDENTIFIER$  (CURRENT)  =  PERS0N1_IDENT$  & 

&  or  NAME$  (CURRENT)  =  PERS0N1_IDENT$  then 

12200  let  PERS0N1_INDEX  =  CURRENT 

12210  let  PERS0N1_F0UND  =  PERS0N1_F0UND  +  1 

12220        end  if 

12230        if  IDENTIFIER$  (CURRENT)  =  PERS0N2_IDENT$  & 

&  or  NAME$  (CURRENT)  =  PERS0N2_IDENT$  then 

12240  let  PERS0N2_INDEX  =  CURRENT 

12250  let  PERS0N2_F0UND  =  PERS0N2_F0UND  +  1 

12260        end  if 

12270  next  CURRENT 

12280  end  sub 

12290  end  !  of  main  program  unit  -  external  procedures  follow 
12300  I 
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12310  !    program-unit  number  2   

12320  ! 

12330  external  sub  FIND_RELATIONSHIP  & 

&  (TARGET_INDEX,  S0URCE_INDEX,  NUMBER_OF_PERSONS ,  & 
&                    NAME$  (),   IDENTIFIER$  (),   GENDER$  (),  RELATIVE_IDENTIFIER$  (,),  & 

&                    NEIGHB0R_COUNT  (),  NEIGHBOR_INDEX  (,),   NEIGHBOR_EDGE  (,),  & 

&                    DISTANCE_FROM_SOURCE   (),   PATH_PREDECESSOR  (),  & 

&                    EDGE_TO_ PREDECESSOR     (),   REACHED  STATUS   (),  & 


&  DESCENDANT_IDENTIFIER$  (),   DESCENDANT_GENES  ()) 

12340  ! 

12350  !  Finds  shortest  path  (if  any)  between  two  PERSONS  and 

12360  !  determines  their  RELATIONSHIP  based  on  immediate  relations 

12370   !  traversed  in  path.     PERSON  array  simulates  a  directed  graph, 

12380  !  and  algorithm  finds  shortest  path,  based  on  following 

12390  !  weights:  PARENT-CHILD  edge  =1.0 

12400  !  SPOUSE -SPOUSE  edge  =  1.8 

12410  ! 

12420  !     declare  subs  and  functions  to  be  used  by  this  program-unit 
12430  ! 

12440  declare  external  sub  COMPUTE_COMMON_GENES 

12450  declare  sub  PROCESS_ADJACENT_NODE,  LINK_NEXT_NODE_TO_BASE_NODE 
12460  declare  sub  RESOLVE_PATH_TO_ENGLISH,  CONDENSE_KEY_PERSONS 
12465  declare  sub  DISPLAY_RELATION 
12470  declare  function  SIBLING_PROXIMITY 
12480  ! 

12483  option  base  1 
12487  ! 

12490  !     Define  global  objects 
12500  ! 

12510  data  300 

12520  read  MAX_PERS0NS 

12530  ! 

12540  data     1,  2  !  for  truth  values 

12550  read     TRUE,  FALSE 
12560  ! 

12570  !     each  PERSON'S  record  in  the  file  identifies  at  most  three 
12580  !     others  directly  related:  father,  mother,  and  spouse 
12590  data  1,  2,  3 

12600  read  FATHER_IDENT,  MOTHER_IDENT,  SPOUSE_IDENT 
12610  ! 

12620  data  M,  F 

12630  read  MALE$,  FEMALE  $ 

12640  ! 

12650  data  000 

12660  read  NULL_IDENT$ 

12670  ! 

12680  data  1,  2,  3,  4,   5,  6,   7,  8 

12690  read  PARENT,  CHILD,  SPOUSE,   SIBLING,  UNCLE,  NEPHEW 
12695  read  COUSIN,  NULL_RELATION 
12700  ! 

12710  !     A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 
12720  !     is  immediately  adjacent  to  those  reached,  or  farther  away. 
12730  data  1,  2,  3 

12740  read  REACHED,  NEARBY,  NOT_SEEN 
12750  ! 
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12760 
12770 
12780 
12790 
12800 
12810 
12820 
12830 
12840 
12850 
12860 
12870 
12880 
12890 
12900 
12910 
12920 
12930 
12940 
12950 
12960 
12970 
12980 
12990 
13000 
13010 
13020 
13030 
13040 
13050 
13060 
13070 
13080 
13090 
13100 
13110 


data  1,   2,  3        !     values  for  search  status 

read  SEARCHING,  SUCCEEDED,  FAILED 

I 

data  1,  2,  3  !  values  for  sibling  proximity 
read  STEP,  HALF,  FULL 


The  following  arrays  contain  information  on  key  persons. 

Key  persons  are  the  ones  in  the  RELATIONSHIP  path  which  remain 

after  the  path  is  condensed. 

RELATI0N_T0_NEXT  (300),  PERS0N_INDEX  (300),  GENERATION_GAP  (300) 
PROXIMITY  (300),  C0USIN_RANK  (300) 

keeps  track  of  current  NEARBY  nodes  in  graph  search 
NEARBY  NODE  (300) 


dim 
dim 
I 
j 

dim 


begin  main  line  of  execution  of  FIND_RELATIONSHIP 

initialize  PERSON-array  for  processing  - 
mark  all  nodes  as  not  seen 
for  THIS_NODE  =  1  to  NUMBER_OF_PERSONS 

let  REACHED_STATUS  (THIS_NODE)  =  NOT_SEEN 

next  THIS_NODE 
! 

let  THIS_NODE  =  SOURCE_INDEX 
!        mark  source  node  as  REACHED 
let  REACHED_STATUS  (THIS_NODE)  =  REACHED 

let  DISTANCE_FROM_SOURCE  (THIS_NODE)  =  0 
!        no  nearby  nodes  exist  yet 
let  LAST_NEARBY_INDEX  =  0 
if  THIS_NODE  =  TARGET_INDEX  then 
let  SEARCH_STATUS  =  SUCCEEDED 
else 

let  SEARCH_STATUS  =  SEARCHING 

end  if 
I 
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13120  !         Loop  keeps  processing  closest-to-source ,  unREACHED  node 

13130  !        until  target  REACHED,  or  no  more  connected  nodes. 

13140  do  while  SEARCH_STATUS  =  SEARCHING 

13150  !        Process  all  nodes  adjacent  to  THIS_NODE 

13160  for  THIS_NEIGHBOR  =  1  to  NEIGHB0R_C0UNT  (THIS_N0DE) 

13170  call  PROCESS_ADJACENT_NODE   (THIS_N0DE,  & 

&  NEIGHBOR_INDEX  (THIS_N0DE,   THIS_NEIGHBOR) ,  & 

&  NEIGHB0R_EDGE     (THIS_N0DE,   THIS_NEIGHBOR) ) 

13180  next  THIS_NEIGHB0R 

-"13190  !        All  nodes  adjacent  to  THIS_N0DE  are  set.     Now  search  for 

13200  !         shortest-distance  unREACHED  (but  NEARBY)  node  to  process  next. 

13210  if  LAST_NEARBY_INDEX  =  0  then 

13220  let  SEARCH_STATUS  =  FAILED 

13230  else     !     determine  next  node  to  process 

13240  let  M I NIMAL_DI STANCE  =  l.OE+18 

13250  !     now  find  closest  unreached  node 

13260  for  THIS_NEARBY_INDEX  =  1  to  LAST_NEARBY_INDEX 

13270  let  NEXT_N0DE  =  NEARBY_N0DE  (THIS_NEARBY_INDEX) 

13280  if  DISTANCE_FR0M_S0URCE  (NEXT_N0DE)  <  MINIMAL_DISTANCE  then 

13290  let  BEST_NEARBY_INDEX  =  THIS_NEARBY_INDEX 

13300  let  MINIMALJDI STANCE     =  DISTANCE_FROM_SOURCE  (NEXT_N0DE) 

13310  end  if 

13320  next  THIS_NEARBY_INDEX 

13330  !       establish  new  THIS_N0DE 

13340  let  THIS_N0DE  =  NEARBY_N0DE  ( BEST_NEARBY_INDEX) 

13350  !       change  THISJJODE  from  being  NEARBY  to  REACHED 

13360  let  REACHED_STATUS  (THIS_N0DE)  =  REACHED 

13370  !       remove  THIS_N0DE  from  NEARBY  list 

13380  let  NEARBY_N0DE  (BEST_NEARBY_INDEX)  =  & 

&  NEARBY_N0DE  (LAST_NEARBY_INDEX) 

13390  let  LAST_NEARBY_INDEX  =  LAST_NEARBY_INDEX  -  1 

13400  if  THIS_N0DE  =  TARGET_INDEX  then  let  SEARCH_STATUS  =  SUCCEEDED 

13410  end  if 

13420  loop 

13430  ! 

13440  !        Shortest  path  between  PERSONS  now  established.     Next  task  is 

13450  !        to  translate  path  to  English  description  of  RELATIONSHIP. 

13460  if  SEARCH_STATUS  =  FAILED  then 

13470  print  "  ";  NAME$  ( TARGE T_INDE X) ;   "  is  not  related  to  ";  & 

&  NAME$  (S0URCE_INDEX) 

13480  else 

13490  !     success  -  parse  path  to  find  and  display  RELATIONSHIP 

13500  call  RES0LVE_PATH_T0_ENGLISH 

13510  call  C0MPUTE_C0MM0N_GENES         (S0URCE_INDEX,  TARGET_INDEX,  & 

&  IDENTIFIER$,  NEIGHB0R_C0UNT,  NEIGHBOR_INDEX,  NEIGHB0R_EDGE ,  & 

&  DESCENDANT  IDENTIFIER$,  DESCENDANT_GENES) 


13520  end  if 
13530  exit  sub 
13540  ! 

13550  !  end  of  main  line  of  execution  of  FIND_RELATIONSHIP 
13560  ! 
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13570  sub  PROCESS_ADJACENT_NODE  (BASE_NODE,  NEXT_NODE,  NEXT_BASE_EDGE ) 
13580  !         NEXT_NODE  is  adjacent  to  last-REACHED  node  (=  BASE_NODE) . 
13590  !         if  NEXT_NODE  already  REACHED,  do  nothing. 
13600  !         If  previously  seen,  check  whether  path  thru  BASE_NODE  is 
13610   !        shorter  than  current  path  to  NEXT_N0DE,  and  if  so  re-link 
13620  !        next  to  base. 

13630  !        If  not  previously  seen,  link  next  to  base  node. 
13640  ! 

13650  if  NEXT_BASE_EDGE  =  SPOUSE  then 
13660        let  WEIGHT_THIS_EDGE  =1.8 
13670  else 

13680        let  WEIGHT_THIS_EDGE  =1.0 
13690  end  if 
13700  ! 

13710  if  REACHED_STATUS   (NEXT_N0DE)  <>  REACHED  then 

13720        let  DISTANCE_THRU_BASE_NODE  & 

&  =  WEIGHT_THIS_EDGE  +  DISTANCE_FR0M_S0URCE  (BASE_NODE) 

13740        if  REACHED_STATUS  (NEXTJNODE)  =  N0T_SEEN  then 

13750  let  REACHED_STATUS   (NEXT_N0DE)  =  NEARBY 

13760  let  LAST_NEARBY_INDEX  =  LAST_NEARBY_INDEX  +  1 

13770  let  NEARBYJJODE  (LAST_NEARBY_INDEX)  =  NEXT_N0DE 

13780  !        link  next  to  base  by  re-setting  its  predecessor  index  to 

13790  !        point  to  base,  note  type  of  edge,  and  re-set  distance 

13800  !        as  it  is  through  base  node. 

13810  let  DISTANCE_FR0M_S0URCE  (NEXTJJODE)  =  DISTANCE_THRU_BASE_NODE 

13820  let  PATH_PREDECESSOR  OJEXT_N0DE)  =  BASE_N0DE 

13830  let  EDGE_T0_PREDECESS0R     (NEXT_N0DE)  =  NEXT_BASE_EDGE 

13840        else       !       REACHED_STATUS  =  NEARBY 

13850  if  DISTANCE_THRU_BASE_NODE  <  DISTANCE_FROM_SOURCE  (NEXT_N0DE )  then 

13860  !        link  next  to  base  by  re-setting  its  predecessor  index  to 

13870  !        point  to  base,  note  type  of  edge,  and  re-set  distance 

13880  !        as  it  is  through  base  node. 

13890  let  DISTANCE_FR0M_S0URCE   (NEXT_N0DE)  =  DISTANCE_THRU_BASE_NODE 

13900  let  PATH_PREDECESSOR  (NEXT_N0DE)  =  BASE_N0DE 

13910  let  EDGE_T0_PREDECESS0R     (NEXT_N0DE )  =  NEXT_BASE_EDGE 

13920  end  if 

13930        end  if 

13940  end  if 

13950  end  sub 

13960  ! 
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13970 
13980 
13990 
14000 
14010 
14020 
14030 
14040 
14050 
14060 
14070 
14080 
14090 
14100 
14110 
14120 
14130 
14140 
14150 
14160 
14170 
14180 
14190 
14200 
14210 
14220 
14230 
14240 
14250 
14260 
14270 
14280 
14290 
14300 
14310 
14320 
14330 


sub  RES0LVE_PATH_T0_ENGLISH 

RESOLVE_PATH_TO_ENGLISH  condenses  the  shortest  path  to  a 
series  of  RELATIONSHIPS  for  which  there  are  English 
descriptions . 

Key  persons  are  the  ones  in  the  RELATIONSHIP  path  which  remain 
after  the  path  is  condensed. 

print  "  Shortest  path  between  identified  persons:  " 
let  THIS_N0DE  =  TARGET_INDEX 

!        print  path  and  initialize  KEY_PERSON  array  from  path  elements, 
!        as  shortest  path  is  traversed, 
let  KEY_INDEX  =  1 

do  until  THIS_NODE  =  SOURCE_INDEX 

let  PERSON_INDEX  (KEY_INDEX)  =  THIS_NODE 

let  PROXIMITY  (KEY_INDEX)  =  FULL 

let  RELATION_TO_NEXT  (KEY_INDEX)  =  EDGE_TO_PREDECESSOR  (THIS_NODE) 
print  "  ";  NAME$  (THIS_NODE);  tab (23);  "is  "; 
if  EDGE_TO_PREDECESSOR  (THIS_NODE)  =  SPOUSE  then 

let  GENERATION_GAP  (KEY_INDEX)  =  0 

print  "spouse  of" 

else 

let  GENERATION_GAP  (KEY_INDEX)  =  1 

if  EDGE_TO_PREDECESSOR  (THIS  NODE)  =  PARENT  then 

print  "parent  of" 
else     !       edge  is  child-type 

print  "child  of" 
end  if 
end  if 

let  KEY_INDEX  =  KEY_INDEX  +  1 

let  THIS  NODE  =  PATH  PREDECESSOR  (THIS  NODE) 


loop 
print 


let  PERSON  INDEX 


NAME$  (THIS_NODE) 
_  (KEY_INDEX) 
let  RELATION_TO_NEXT  (KEY_INDEX)  _ 
let  RELATION_TO_NEXT  (KEY_INDEX  +  1)  =  NULL_RELATION 
I 


=  THIS_NODE 

=  NULL  RELATION 
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14340  !        Resolve  CHILD-PARENT  and  CHILD-SPOUSE-PARENT  relations 

14350  !        to  SIBLING  relations. 

14360  let  KEY_INDEX  =  1 

14370  do  until  RELATI0N_T0_NEXT  (KEYJENDEX)  =  NULL_RELATI0N 

14380  if  RELATI0N_T0_NEXT  (KEY_INDEX)  =  CHILD  then 

14390  let  LATER_KEY_RELATION  =  RELATI0N_T0_NEXT  (KEY_INDEX  +  1) 

14400  if  LATER_KEY_RELATION  =  PARENT  then 

14410  !       found  either  full  or  half  SIBLINGS 

14420  let  GENERATION_GAP       (KEY_INDEX)  =  0 

14430  let'  RELATI0N_T0_NEXT  (KEY_INDEX)  =  SIBLING 

14440  let  PROXIMITY  (KEY_INDEX)  =  & 

&  SIBLING_PROXIMITY  (PERSONJENDEX  (KEY_INDEX) ,  & 

&  PERS0N_INDEX  (KEY_INDEX  +2)) 

14450  call  CONDENSE_KEY_PERSONS  (KEY_INDEX,  1) 

14460  else 

14470  if  LATER_KEY_RELATION  =  SPOUSE  and  & 

&  RELATI0N_T0_NEXT  (KEY_INDEX  +  2)  =  PARENT  then 

14480  !       found  step-siblings 

14490  let  GENERATION_GAP       (KEY_INDEX)  =  0 

14500  let  RELATI0N_T0_NEXT  (KEY_INDEX)  =  SIBLING 

14510  let  PROXIMITY  (KEY_INDEX)  =  STEP 

14520  call  C0NDENSE_KEY_PERS0NS  (KEY_INDEX,  2) 

14530  end  if 

14540  end  if 

14550  end  if 

14560  let  KEY_INDEX  =  KEY_INDEX  +  1 

14570  loop 

14580  ! 

14590  !        Resolve  CHILD-CHILD-. . .  and  PARENT-PARENT-. . .  relations  to 

14600  !        direct  descendant  or  ancestor  relations. 

14610  let  KEY_INDEX  =  1 

14620  do  until  RELATI0N_T0_NEXT  (KEY_INDEX)  =  NULL_RELATI0N 

14630  if  RELATI0N_T0_NEXT  (KEY_INDEX)  =  CHILD  or  & 

&  RELATI0N_T0_NEXT  (KEY_INDEX)  =  PARENT  then 

14640  let  LATER_KEY_INDEX  =  KEY_INDEX  +  1 

14650  do  while  RELATION_TO_NEXT  (LATER_KEY_INDEX)  & 

&  =  RELATION_TO_NEXT  (KEY_INDEX) 

14660  let  LATER_KEY_INDEX  =  LATER_KEY_INDEX  +  1 

14670  loop 

14680  let  GENERATI0N_C0UNT  =  LATER_KEY_INDEX  -  KEY_INDEX 

14690  if  GENERATI0N_C0UNT  >  1    then        !        compress  generations 

14700  let  GENERATION_GAP  (KEY_INDEX)  =  GENERATI0N_C0UNT 

14710  call  C0NDENSE_KEY_PERS0NS  (KEY_INDEX,   GENERATI0N_C0UNT  - 

14720  end  if 

14730  end  if 

14740  let  KEY  INDEX  =  KEY  INDEX  +  1 


14750  loop 
14760  ! 
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14770  !         Resolve  CHILD-SIBLING-PARENT  to  COUSIN, 

14780  !                       CHILD-SIBLING  to  NEPHEW, 

14790  !                       SIBLING-PARENT  to  UNCLE. 

14800  let  KEY_INDEX  =  1 

14810  do  until  RELATION_TO_NEXT  (KEY_INDEX)  =  NULL_RELATION 

14820  let  LATER_KEY_RELATION  =  RELATI0N_T0_NEXT  (KEY_INDEX  +  1) 

14830  if  RELATI0N_T0_NEXr  (KEY_INDEX)  =  CHILD  & 

&  and  LATER_KEY_RELATION  =  SIBLING  then 

14840  !     found  COUSIN  or  NEPHEW 

14850  if  RELATION_TO_NEXr  (KEY_INDEX  +  2)  =  PARENT  then 

14860  !     found  cousin 

14870  let  GAPl  =  GENERATION_GAP  (KEY_INDEX) 

14880  let  GAP2  =  GENERATION_GAP  (KEY_INDEX  +  2) 

14890  let  C0USIN_RANK  (KEY_INDEX)  =  min  (GAPl,     GAP2 ) 

14900  let  GENERATIONJSAP      (KEY_INDEX)  =  abs  (GAPl  -  GAP2) 

14910  let  PROXIMITY  (KEY_INDEX)  =  PROXIMITY  (KEY_INDEX  +  1) 

14920  let  RELATI0Njr0_NEXT  (KEY_INDEX)  =  COUSIN 

14930  call  C0NDENSE_KEY_PERS0NS  (KEY_INDEX,  2) 

14940  else       !       found  NEPHEW 

14950  let  PROXIMITY  (KEY_INDEX)  =  PROXIMITY  (KEY_INDEX  +  1) 

14960  let  RELATI0N_T0_NEXT  (KEY_INDEX)  =  NEPHEW 

14970  call  C0NDENSE_KEY_PERS0NS  (KEY_INDEX,  1) 

14980  end  if 

14990  else 

15000  if  RELATI0N_T0_NEXT  (KEY_INDEX)  =  SIBLING  & 

&  and  LATER_KEY_RELATION  =  PARENT  then 

15010  !       found  UNCLE 

15020  let  GENERATIONJSAP       (KEY_INDEX)  =  & 

&  GENERATION_GAP       (KEY_INDEX  +  1) 

15030  let  RELATION_TO_NEXT  (KEY_INDEX)  =  UNCLE 

15040  call  CONDENSE_KEY_PERSONS  (KEY_INDEX,  1) 

15050  end  if 

15060  end  if 

15070  let  KEY_INDEX  =  KEY_INDEX  +  1 

15080  loop 

15090  ! 
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15100  !          Loop  below  will  pick  out  valid  adjacent  strings  of  elements 

15110  !          to  be  printed.     KEY_INDEX  points  to  first  element, 

15120  !          LATER_KEY_INDEX  to  last  element,  and  PRIMARY_INDEX  to  the 

15130  !          element  which  determines  the  primary  English  word  to  be  used. 

15140  !          Associativity  of  adjacent  elements  in  condensed  table 

15150  !          is  based  on  English  usage. 

15160  print  "  Condensed  path:" 

15170  let  KEY_INDEX  =  1 

15180  do  until  RELATION_TO_NEXT  (KEY_INDEX)  =  NULLJRELATION 

15190  let  KEY_RELATI0N  =  RELATION_TO_NEXT  (KEY_INDEX) 

15200  let  LATER_KEY_INDEX,   PRIMARY_INDEX  =  KEY_INDEX 

15210  if  RELATION_TO_NEXT  (KEY_INDEX  +  1)  <>  NULL_RELATI0N  then 

15220  !       seek  multi-element  combination 

15230  let  ANOTHER_ELEMENT_POSSIBLE  =  TRUE 

15240  if  KEY_RELATI0N  =  SPOUSE  then 

15250  let  LATER_KEY__INDEX  =  LATER_KEY_INDEX  +  1 

15260  let  PRIMARY_INDEX      =  LATER_KEY_INDEX 

15270  if  RELATI0N_T0_NEXT  (LATER_KEY_INDEX)  =  SIBLING  or  & 

&  RELATI0N_T0_NEXT  (LATER_KEY__INDEX)  =  COUSIN  then 

15280  !       nothing  can  follow  spouse-sibling  or  spouse-cousin 

15290  let  ANOTHER_ELEMENT_POSSIBLE  =  FALSE 

15300  end  if 

15310  end  if 

15320  !        PRIMARY_INDEX  is  now  correctly  set.     Next  if-statement 

15330  !        determines  if  a  following  SPOUSE  relation  should  be 

15340  !        appended  to  this  combination  or  left  for  the  next 

15350  !  combination. 

15360  if  RELATI0N_T0_NEXT  (PRIMARY_INDEX  +  1)  =  SPOUSE  and  & 

&  ANOTHER_ELEMENT_POSSIBLE  =  TRUE  then 

15370  !       Only  a  SPOUSE  can  follow  a  Primary 

15380  !       check  primary  preceding  and  following  SPOUSE. 

15390  let  PRIMARY_RELATION  =  RELATION_TO_NEXT  (PRIMARY_INDEX) 

15400  let  NEXT_PRIMARY_RELATION  =  RELATION_TO_NEXT  (PRIMARY_INDEX  + 

15410  if  (NEXT_PRIMARY_RELATION  =  NEPHEW      or  & 

&  NEXT_PRIMARY_RELATION  =  COUSIN      or  & 

&  NEXr_PRIMARY_RELATION  =  NULL_RELATI0N)  & 

&  or  (PRIMARY_RELATION  =  NEPHEW)  & 

&  or  (   (PRIMARY_RELATION  =  SIBLING    or  & 

&  PRIMARY_RELATION  =  PARENT)  & 

&  and  NEXT_PRIMARY_RELATION  <>  UNCLE  )  then 

15420  !       append  following  SPOUSE  with  this  combination 

15430  let  LATER_KEY_INDEX  =  LATER_KEY_INDEX  +  1 

15440  end  if 

15450  end  if 

15460  end  if        !      multi-element  combination 

15470  call  DISPLAY_RELATION  (KEY_INDEX,   LATER_KEY_INDEX,  PRIMARY_INDEX) 

15480  let  KEY_INDEX  =  LATER_KEY_INDEX  +  1 

15490  loop 

15500  ! 

15510  print  "  ";   NAME$  (PERS0N_INDEX  (KEY_INDEX)) 

15520  end  sub 

15530  !     end  of  RESOLVE_PATH_TO_ENGLISH 

15540  ! 
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15550  function  SIBLING_PROXIMITY  (INDEXl,  INDEX2) 

15560  !     Determines  whether  two  PERSONS  are  full  siblings,  i.e., 

15570  !     have  the  same  two  parents . 

15580  if  RELATIVE_IDENTIFIER$  (INDEXl,  FATHER_IDENT)  <>  NULL_IDENT$  and 
&  RELATIVE_IDENTIFIER$  (INDEXl,  M0THER_IDENT)   <>  NULL_IDENT$  and 

&  RELATIVE_IDENT1FIER$  (INDEXl,   FATHER_IDENT )  = 

&  RELATIVE_IDENTIFIER$   (INDEX2,   FATHER_IDENT)  and 

&  RELATIVE_IDENTIFIER$  (INDEXl,  M0THER_IDENT)  = 

&  RELATIVE_IDENTIFIER$   (INDEX2,  M0THER_IDENT ) 

15590        let  SIBLINGJPROXIMITY  =  FULL 
15600  else 

15610        let  SIBLING_PROXIMITY  =  HALF 
15620  end  if 

15630  end  function       !  SIBLING_PROXIMITY 
15640  ! 

15650  sub  C0NDENSE_KEY_PERS0NS  (AT_INDEX,  GAP_SIZE) 

15660  !       C0NDENSE_KEY_PERS0NS  condenses  superfluous  entries  from  the 
15670  !      key  person  array  entries,  starting  at  AT  INDEX 
15680  let  RECEIVE_INDEX  =  AT_INDEX 
15690  do 

15700        let  RECEIVE_INDEX  =  RECEIVE_INDEX  +  1 
15710        let   SEND_INDEX        =  RECEIVE_INDEX  +  GAP_SIZE 

15720        let  RELATI0N_T0_NEXT  (RECEIVE_INDEX)  =  RELATI0N_T0_NEXT  (SEND 
15730         let  PERS0N_INDEX  (RECEIVE_INDEX)  =  PERS0N_INDEX  (SEND~ 

15740  let  GENERATION_GAP  (RECEIVE_INDEX)  =  GENERATION_GAP  (SEND' 
15750        let  PROXIMITY  (RECEIVE_INDEX)  =  PROXIMITY  (SEND^ 

15760        let  C0USIN_RANK  (RECEIVE_INDEX)  =  C0USIN_RANK  (SEND_ 

15770  loop  until  RELATION_TO_NEXT  (SEND_INDEX)  =  NULL_RELATI0N 
15780  end  sub 
15790  ! 

15800  sub  DISPLAY_RELATION  (FIRST_INDEX,   LAST_INDEX,  PRIMARY_INDEX) 
15810   !       DISPLAYJRELATION  takes  1,   2,  or  3  adjacent  elements  in  the 
15820  !      condensed  table  and  generates  the  English  description  of 
15830  !       the  relation  between  the  first  and  last  +  1  elements. 
15840  ! 

15850  let  FIRST_RELATION      =  RELATI0N_T0_NEXT  (FIRST_INDEX) 
15860  let  LAST_RELATI0N        =  RELATI0N_T0_NEXT  (LAST_INDEX) 
15870  let  PRIMARY_RELATION  =  RELATION_TO_NEXT  (PRIMARY_INDEX) 
15880  ! 

15890  !     set  THIS_PROXIMITY 

15900  if  (PRIMARY_RELATION  =  PARENT  and  FIRST_RELATION  =  SPOUSE)  or 
&  (PRIMARY_RELATION  =  CHILD    and  LAST_RELATION    =  SPOUSE)  then 

15910        let  THIS_PROXIMITY  =  STEP 
15920  else 

15930        if  PRIMARY_RELATION  =  SIBLING  or  & 

&  PRIMARY_RELATION  =  UNCLE      or  & 

&  PRIMARY_RELATION  =  NEPHEW    or  & 

&  PRIMARY_RELATION  =  COUSIN  then 

15940  let  THIS_PROXIMITY  =  PROXIMITY  (PRIMARY_INDEX) 

15950  else 

15960  let  THIS_PROXIMITY  =  FULL 

15970        end  if 
15980  end  if 
15990  ! 


& 
& 
& 
& 
& 
ther 


INDEX) 
INDEX) 
INDEX) 
INDEX) 
INDEX) 
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16000 

16010 

& 

& 

& 

& 

16020 

16030 

16040 

16050 

16060 

16070 

16080 

& 

& 

& 

& 

16090 

16100 

16110 

& 

& 

& 

& 

16120 

16130 

16140 

16150 

16160 

16170 

16180 

16190 

16200 

16210 

16220 

16230 

16240 

16250 

16260 

16270 

16280 

& 

& 

& 

16290 
16300 
16310 
16320 
16330 
16340 
16350 
16360 
16370 


!  set  THIS_GENERATION_GAP 
if  PRIMARY_RELATION  =  PARENT  or 
PRIMARY_RELATION  =  CHILD  or 
PRIMARY_RELATION  =  UNCLE  or 
PRIMARY_RELATION  =  NEPHEW  or 
PRIMARY  RELATION  =  COUSIN 


then 

let  THIS_GENERATION_GAP  =  GENERATION_GAP  (PRIMARY_INDEX) 
else 

let  THIS_GENERATION_GAP  =  0 

end  if 
I 

!     set  INLAW 

if  (FIRST_RELATION  =  SPOUSE)  and  & 
(PRIMARY_RELATION  =  SIBLING  or  & 
PRIMARY_RELATION  =  CHILD      or  & 
PRIMARY_RELATION  =  NEPHEW     or  & 
PRIMARY_RELATION  =  COUSIN)  then 
let  INLAW  =  TRUE 
else 

if  (LAST_RELATI0N  =  SPOUSE)  and  & 
(PRIMARY_RELATION  =  SIBLING  or  & 
PRIMARY_RELATION  =  PARENT    or  & 
PRIMARY_RELATION  =  UNCLE      or  & 
PRIMARY_RELATION  =  COUSIN)  then 
let  INLAW  =  TRUE 
else 

let  INLAW  =  FALSE 

end  if 

end  if 
j 

!     set  THIS_COUSIN_RANK 

if  PRIMARY_RELATION  =  COUSIN  then 

let  THIS_COUSIN_RANK  =  C0USIN_RANK  (PRIMARY_INDEX) 
else 

let  THIS_COUSIN_RANK  =  0 
end  if 
! 

!        parameters  are  set  -  now  generate  display. 


print 


NAME$  (PERSON  INDEX  (FIRST  INDEX));  tab(23);  "is 


PRIMARY_RELATION  =  PARENT  or  & 
PRIMARY_RELATION  =  CHILD    or  & 
PRIMARY_RELATION  =  UNCLE     or  & 
PRIMARY_RELATION  =  NEPHEW  then 
!     print  generation-qualifier 
if  THIS_GENERATION_GAP  >=  3  then 
print  "great"; 

if  THIS_GENERATION_GAP  >  3  then 

print  "*";  str$  (THIS_GENERATION_GAP  -  2); 
end  if 
print  "-"; 
end  if 

if  THIS  GENERATION  GAP  >=  2  then  print  "grand-"; 
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16380 
16390 
16400 
16410 
16420 
16430 
16440 
16450 
16460 
16470 
16480 
16490 
16500 
16510 
16520 
16530 


if  THIS  PROXIMITY 


end  if 


elseif  PRIMARY  RELATION  =  COUSIN  and  THIS  COUSIN  RANK  >  1  then 


print  str$   (THIS  COUSIN  RANK); 


end  select 


print  "step-"; 


select  case  mod  (THIS_C0USIN  RANK,  10) 


case  3 

print  "rd  " 


case  else 

print  "th  " 


case  2 

print  "nd  " 


case  1 

print  "st  " 


STEP  then 


16540  elseif  THIS_PROXIMITY  =  HALF  then 
16550        print  "half-"; 

16560  end  if 

16570  ! 

16580  let  THIS  GENDER$  =  GENDER$  (PERSON  INDEX  (FIRST  INDEX)) 


16590 

select 

case 

PRIMARY  RELATION 

16600 

case 

1 

!  PARENT 

16610 

if 

THIS 

GENDER$  =  MALE$ 

then 

print 

"father" ; 

else 

print 

"mother" ; 

16620 

case 

2 

!  CHILD 

16630 

if 

THIS 

GENDER$  =  MALE$ 

then 

print 

"son" ; 

else 

print 

"daughter" ; 

16640 

case 

3 

!  SPOUSE 

16650 

if 

THIS 

GENDER$  =  MALE$ 

then 

print 

"husband" ; 

else 

print 

"wife" ; 

16660 

case 

4 

!  SIBLING 

16670 

if 

THIS 

GENDER$  =  MALE$ 

then 

print 

"brother" ; 

else 

print 

"sister" ; 

16680 

case 

5 

!  UNCLE 

16690 

if 

THIS 

GENDER $  =  MALE$ 

then 

print 

"uncle" ; 

else 

print 

"aunt" ; 

16700 

case 

6 

!  NEPHEW 

16710 

if 

THIS 

GENDER$  =  MALE$ 

then 

print 

"nephew" ; 

else 

print 

"niece" ; 

16720 

case 

7 

!  COUSIN 

16730  print  "cousin"; 

16740      case  else 
16750         print  "null"; 
16760  end  select 
16770  ! 

16780  if  INLAW  =  TRUE  then  print  "-in-law"; 
16790  ! 

16800  if  PRIMARY_RELATION  =  COUSIN  and  THIS_GENERATION_GAP  >  0  then 

16810        if  THIS_GENERATION_GAP  >  1  then 

16820  print  THIS_GENERATION_GAP;   "times  removed"; 

16830  else 

16840  print  "  once  removed"; 

16850        end  if 
16860  end  if 
16870  ! 

16880  print  "  of" 
16890  ! 

16900  end  sub     !     end  of  internal  sub  DISPLAY_RELATION 
16910  end  sub     !     end  of  external  sub  FIND_RELATIONSHIP 
16920  ! 
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16930  !  — ■ —  program-unit  number  3  — — 
16940  ! 

16950  external  sub  COMPUTE_COMMON_GENES  (INDEXl,  INDEX2,  IDENTIFIER$  (),  & 
&  NEIGHB0R_C0UNT  (),  NEIGHBOR_INDEX  (,),  NEIGHB0R_EDGE  (,),  & 

&  DESCENDANT_IDENTIFIER$  (),  DESCENDANT_GENES  ()) 

16960  ! 

16970  !  C0MPUTE_C0MM0N_GENES  assumes  that  each  ancestor  contributes 

16980  !  half  of  the  genetic  material  to  a  person.     It  finds  common 

16990  !  ancestors  between  two  persons  and  computes  the  expected 

17000  !  value  of  the  PROPORTION  of  common  material. 

17010  ! 

17020  declare  sub  ZER0_PR0P0RTI0N,  MARK_PR0P0RTI0N,  CHECK_C0MM0N_PR0P0RTI0N 
17030  ! 

17035  option  base  1 
17040  ! 

17045  data  1,  2,  3,  4,   5,  6,   7,  8 

17050  read  PARENT,  CHILD,  SPOUSE,   SIBLING,  UNCLE,  NEPHEW 
17055  read  COUSIN,  NULL_RELATION 
17057  ! 

17060   !         Begin  main  line  of  execution  of  COMPUTE_COMMON_GENES 
17065  ! 

17070  !        First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 
17075  !        because  there  might  be  two  paths  to  an  ancestor. 
17080  call  ZEROJPROPORTION  (INDEXl,  0) 
17090  !        now  mark  with  shared  PROPORTION 

17100  call  MARK_PROPORTION  (IDENTIFIER$  (INDEXl),   1.0,   INDEXl,  0) 
17110  let     COMMON_PRO PORTION  =0.0 

17120  call  CHECK_C0MM0N_PR0P0RTI0N  (C0MM0N_PR0 PORTION,  & 
&  IDENTIFIER$  (INDEXl),   1.0,   0.0,  INDEX2,  0) 

17130  print  using  "  Proportion  of  common  genetic  material  =  #.#####^       ":  & 
&  C0MM0N_PR0P0RTI0N 
17140  ! 

17150  !        End  main  line  of  execution  of  C0MPUTE_C0MM0N_GENES 
17160  ! 

17170  sub  ZER0_PR0P0RTI0N  (ZER0_INDEX,  THIS_NEIGHB0R) 

17180  !     ZER0_PR0 PORTION  recursively  seeks  out  all  ancestors  and 

17190  !     zeros  them  out 

17200  let  DESCENDANT_GENES  (ZER0_INDEX)  =0.0 

17210  for  THIS_NEIGHBOR  =  1  to  NEIGHBOR_COUNT  (ZERO_INDEX) 

17220        if  NEIGHBOR_EDGE  (ZERO_INDEX,   THIS_NEIGHBOR)  =  PARENT  then 

17230  call  ZER0_PR0 PORTION  & 

&  (NEIGHBOR_INDEX  (ZERO_INDEX,  THIS_NEIGHBOR) ,  0) 

17240        end  if 

17250  next  THIS_NEIGHBOR 

17260  end  sub       !  ZERO_PROPORTION 

17270  ! 


Page  51 


17280  sub  MARK_PRO PORTION  (MARKER$,  PROPORTION,  MARKED_INDEX,  THIS_NEIGHBOR ) 
17290  !     MARK_PROPORTION  recursively  seeks  out  all  ancestors  and 

17300  !     marks  them  with  the  sender's  PROPORTION  of  shared 

17310  !     genetic  material.     This  PROPORTION  is  diluted  by  one-half 

17320  !     for  each  generation 

17330  let  DESCENDANT_IDENTIFIER$  (MARKED_INDEX)  =  MARKER$ 

17340  let  DESCENDANT_GENES  (MARKED_INDEX)  =  & 

&  DESCENDANT_GENES  (MARKED_INDEX)  +  PROPORTION 

17350  for  THIS_NEIGHBOR  =  1  to  NEIGHBORjCOUNT  (MARKED_INDEX) 

17360        if  NEIGHBOR_EDGE  (MARKED_INDEX,  THIS_NEIGHBOR)  =  PARENT  then 

17370  call  MARK_PRO PORTION  (MARKER$,   PROPORTION  /  2.0,  & 

&  NEIGHBOR_INDEX  (MARKED_INDEX,  THIS_NEIGHBOR) ,  0) 

17380        end  if 

17390  next  THIS_NEIGHBOR 

17400  end  sub      !       MARK_PRO PORTION 

17410  ! 

17420  sub  CHECK_COMMON_PRO PORTION  (COMMON_PRO PORTION,  MATCH_IDENTIFIER$,  & 

&  PROPORTION,  ALREADYjCOUNTED,  CHECK_INDEX,  THIS_NEIGHBOR) 

17430  !     CHECK_COMMON_PROPORTION  searches  all  the  ancestors  of 

17440  !     CHECK_INDEX  to  see  if  any  have  been  marked,  and  if  so 

17450  !     adds  the  appropriate  amount  to  COMMON_PROPORTION 

17460  if  DESCENDANT_IDENTIFIER$  (CHECK_INDEX)  =  MATCH_IDENTIFIER$  then 

17470        !     Increment  COMMON_PROPORTION  by  the  contribution  of 

17480        !     this  common  ancestor,  but  discount  for  the  contribution 

17490        !     of  less  remote  ancestors  already  counted 

17500        let  THISjCONTRIBUTION  =  DESCENDANT_GENES  (CHECK_INDEX)  *  PROPORTION 
17510        let  COMMON_PROPORTION  =  COMMON_PROPORTION  & 
&  +  THISJCONTRIBUTION  -  ALREADY_COUNTED 

17520  else 

17530        let  THIS_CONTRIBUTION  =0.0 
17540  end  if 

17550  for  THIS_NEIGHBOR  =  1  to  NEIGHBORJCOUNT  (CHECK_INDEX) 

17560        if  NEIGHBOR_EDGE  (CHECK_INDEX,  THIS_NEIGHBOR)  =  PARENT  then 

17570  call  CHECK_COMMON_PROPORTION  (COMMON_PROPORTION ,  & 

&  MATCH_IDENTIFIER$,   PROPORTION  /  2.0,  & 

&  THISJCONTRIBUTION  /  4.0,  & 

&  NEIGHBOR_INDEX  (CHECK_INDEX,   THIS_NEIGHBOR) ,  0) 

17610        end  if 

17620  next  THIS_NEIGHBOR 

17630  ! 

17640  end  sub       !       end  of  internal  sub  CHECKjCOMMON_PRO PORTION 
17650  end  sub      !       end  of  external  sub  COMPUTE  COMMON  GENES 
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4.0  C 

The  identifiers  NULL  and  FILE  are  capitalized,  even  though  they  are  supplied  by 

the     standard    run-time    library,  because     identifiers  in  C  are  case-sensitive, 

e.g.,  "null"  is  not  equivalent  to  "NULL". 

/*  Bring  in  standard  routines  for  run-time  support  */ 

//include  <stdio.h> 

/*  Global  types  and  objects  */ 

typedef  short  int  BOOLEAN; 
//define  TRUE  1 
//define  FALSE  0 
//define  EQUALS  0 

//define  NULL_ID  "000" 
//define  NULLjCHR  '\0' 

//define  MAX_PERS  300 
//define  NAME_LEN  20 

/*  every  PERSON  has  a  unique  3-digit  IDENT  */ 
//define  ID_LEN  3 
//define  BUF_LEN  60 

/*  Use  "+  1"  when  treating  type  as  variable-length  -  extra  character 
used  to  hold  NULL_CHR  termination  character.  */ 
typedef  char    NAMEJT'^P     [NAME_LEN  +  1]; 
typedef  char    BUF_TYPE     [BUF_LEN  +  1]; 
typedef  char    MSG_TYPE     [40  +1]; 
typedef  char     ID_TYPE       [ID_LEN  +1]; 

typedef  int      INDXJTYP,  COUNTER; 

/*  each  person's  record  in  the  file  identifies  at  most  thre- 
others  directly  related:  father,  mother,  and  spouse  */ 

typedef  short  int  GIVEN_ID; 
//define     FATHR_ID  0 
//define    MOTHR_ID  1 
//define     SPOUS_ID  2 
//define    MAX_GVEN  3 

typedef  IDJTYPE  REL_ARRY  [MAX_GVEN]; 

//define  REQjDK  "Request  OK" 

//define  REQ_STOP  "stop" 

typedef  char  GNDR_TYP; 
//define  MALE  'M' 
//define  FEMALE  'F' 
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typedef  unsigned  int    REL_TYPE ; 

/*  Values  defined  as  octal  powers  of  two  to  facilitate  comparisons 
of  one  relation  with  several  possibilities.  */ 


//define 

PARENT 

0001 

#define 

CHILD 

0002 

#define 

SPOUSE 

0004 

#def ine 

SIBLING 

0010 

#define 

UNCLE 

0020 

//define 

NEPHEW 

0040 

//def  ine 

COUSIN 

0100 

//define 

NULL  REL 

0200 

/*  directed  edges  in  the  graph  are  of  a  given  type  */ 
typedef  RELJTYPE  EDG_TYPE; 

/*  A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 

is  immediately  adjacent  to  those  reached,  or  farther  away.  */ 

typedef  short  int  REACHJTY; 
//define  REACHED  1 
//define  NEARBY  2 
//define  NOT  SEEN  3 


/*  each  PERSON  has  a  linked  list  of  adjacent  nodes,  called  neighbors  */ 
typedef  struct  NBR_N0DE 

{  INDXJTYP  NBR_DEX; 

EDGJTYPE  NBR_EDGE ; 

struct  NBR_N0DE  *NEXT_NBR; 

} 

NBR_REC,  *NBR_PTR; 

/*  All  relationships  are  captured  in  the  directed  graph  of  which 

each  record  is  a  node .  */ 
typedef  struct 

{ 

/*  static  information  -  filled  from  PEOPLE  file:  */ 
NAMEJIYP  NAME ; 

ID_TYPE  IDE NT; 

GNDRJTYP  GENDER ; 

/*  IDENTs  of  immediate  relatives  -  father,  mother,  spouse  */ 
REL_ARRY  REL_ID; 

/*  head  of  linked  list  of  adjacent  nodes  */ 

NBR_PTR  NBR_HDR; 
/*  data  used  when  traversing  graph  to  resolve  user  request:  */ 

float  DIST_SRC ; 

INDXJTYP  PATHPRED; 

EDGJTYPE  EDG_PRED; 

REACHJTY  REACH_3T; 
/*  data  used  to  compute  common  genetic  material  */ 

IDJTYPE  DSC_ID; 

float  DSC_GENE ; 

} 

PERS  REC; 
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/«  the  PERSON  array  Is  the  central  repository  of  Information 

about  inter-relatlonshlps .  */ 
PERS_REC  PERSON  [MAX_PERS]; 

INDX_TYP  NUM_PERS; 

/*  Key  persons  are  the  ones  In  the  RELJSHIP  path  which  remain 
after  the  path  is  condensed.  •/ 


typedef  short  int  SIB_TYPE; 
//define  STEP  1 
#def ine  HALF  2 
^define  FULL  3 


typedef  struct 
{  REL_TYPE 
INDXJTYP 
COUNTER 
SIB_TYPE 
COUNTER 

} 

KEY  REC; 


RELJIEXT; 
PERS_DEX; 
GEN_GAP; 
PROXIMTY; 
CUZ  RANK; 


/»»»»»*»»*»  Main  line  of  execution  RELATE  »«*»»»»»»»/ 


main  ( ) 


{  /*  These  variables  are  used  when  establishing  the  PERSON  array 
from  the  PEOPLE  file.  »/ 


FILE 

register  INDXJTYP 

IDJTYPE 

GIVEN_ID 

char 


»fopen(),  "PEOPLE; 

CURRENT,  PREVIOUS; 

PREV_ID,  CUR_ID; 

RELJSHIP; 

INP  BUF  [100]; 


/*  These  variables  are  used  to  accept  and  resolve  requests  for 

RELJSHIP  information.  »/ 
COUNTER  SEMI_LOC ; 

BUFJTYPE  REQ_BUF; 

BUFJTYPE  P1_IdENT,  P2_IDENT; 

COUNTER  P1_F0UND,  P2_F0UND; 

MSGJTYPE  ERR  MSG; 

INDXJTYP  PI  TNDEX,  P2  INDEX; 
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/*  ***  execution  of  main  sequence  begins  here  ***  */ 
PEOPLE  =  f open ("PEOPLE. DAT",  "r"); 

/*  This  loop  reads  in  the  PEOPLE  file  and  constructs  the  PERSON 
array  from  it  (one  PERSON  ==  one  record  ==  one  array  entry). 
As  records  are  read  in,  links  are  constructed  to  represent  the 
PARENT -CHILD  or  SPOUSE  REL_SHIP.     The  array  then  Implements 
a  directed  graph  which  is  used  to  satisfy  subsequent  user 
requests.     The  file  is  assumed  to  be  correct  -  no  validation 
is  performed  on  it .  */ 
READ_PEO: 

for  (CURRENT  =0;    ;  CURRENT-H-) 

{ 

/*  copy  direct  information  from  file  to  array  */ 
if  (PXD_GETC  (PERSON   [CURRENT]    .   NAME,   PEOPLE,  NAME_LEN) 
==  EOF) 

break; 

FXD_GETC  (PERSON  [CURRENT]  .  IDENT,  PEOPLE,  ID_LEN); 
FXD_GETC  (&(PERSON  [CURRENT]  .  GENDER),  PEOPLE,  1); 
for  (REL_SHIP  =  FATHR_ID;  REL_SHIP  <  MAX_GVEN;  REL_SHIP-H-) 

FXD_GETC  (PERSON  [CURRENT]   .  REL_ID   [REL_SHIP] ,   PEOPLE,  ID_LEN); 
/*  flush  remainder  of  record  */ 
fgets  (1NP_BUF,   100,  PEOPLE); 

/*  Location  of  adjacent  persons  as  yet  undetermined  */ 

PERSON   [CURRENT]   .  NBR_HDR  =  NULL; 

/*  Descendants  as  yet  undetermined  */ 

St ropy  (PERSON  [CURRENT]   .  DSC_ID,  NULL_ID); 

/*  Compare  this  PERSON  against  all  previously  entered  PERSONS 

to  search  for  REL_SHIPs .  */ 
strcpy  (CUR_ID,   PERSON  [CURRENT]   .  IDENT); 
CMP_PREV: 

for  (PREVIOUS  =  0;  PREVIOUS  <  CURRENT;  PREVIOUS-H-) 

{ 

strcpy  (PREV_ID,   PERSON  [PREVIOUS]   .  IDENT); 

/*  Search  for  father,  mother,  or  spouse  relationship  in 

either  direction  between  this  and  PREVIOUS  PERSON. 

Assume  at  most  one  REL_SHIP  exists.  */ 

TRY_RELS : 

for  (REL_SHIP  =  FATHR_ID;  REL_SHIP  <  MAX_GVEN;  REL_SHIP++) 

{ 

if  (STREQ  (PRE V_ID, PERSON  [CURRENT]   .  REL_ID  [REL_SHIP])) 

{ 

LINK_REL  (CURRENT,  REL_SHIP,  PREVIOUS); 

break; 

} 

else 

if  (STREQ  (CUR_ID,   PERSON   [PREVIOUS]    .   REL_ID  [REL_SHIP])) 

{ 

LINK_REL  (PREVIOUS,  REL_SHIP,  CURRENT); 

break; 

} 

}     /*  end  TRY_RELS  */ 
}     /*  end  CMP_PREV  */ 
}     /*  end  READJPEO  */ 
NUM_PERS  =  CURRENT; 
f close  (PEOPLE); 
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/*  PERSON  array  is  now  loaded  and  edges  between  immediate  relatives 
(PARENT -CHILD  or  SPOUSE -SPOUSE)  are  established. 

While-loop  accepts  requests  and  finds  REL_SHIP  (if  any) 
between  pairs  of  PERSONS.  */ 

PROC_REQ: 

while  (TRUE) 
{ 

PROMPT  (REQ_BUF); 
if  (STREQ  (REQ_BUF,  REQ_STOP)) 
break; 

SEMI_LOC  =  CHK_RQST  (REQ_BUF,  ERR_MSG); 

/*  Syntax  check  of  request  completed.     Now  either  display  error  * 
message  or  search  for  the  two  PERSONS.  */ 

if  (STREQ  (ERR_MSG,  REQ_OK)) 

{     /*  Request  syntactically  correct  -  search  for  requested  PERSONS.  */ 
REQ_BUF   [SEMI_LOC]   =  NULL_CHR; 
BUF_PERS  (REQ_BUF,  0,  P1_IDENT); 
BUF_PERS  (REQJBUF,   SEMI_LOC  +  1,  P2_IDENT); 
SEEK_PER  (P1_IDENT,   P2_IDENT,  &  P1_INDEX,  &  P2_INDEX, 

&  P1_F0UND,  &  P2_F0UND); 
if  (P1_F0UND  ==  1  &&  P2_F0UND  ==  1) 

/*  Exactly  one  match  for  each  PERSON  -  proceed  to 

determine  REL_SHIP,  if  any.  */ 
if  (P1_INDEX  ==  P2_INDEX) 

printf  ("  %ls  is  identical  to  %8s  \n" , 
PERSON  [P1_INDEX]   .  NAME, 
(PERSON  [P1_INDEX]   .   GENDER  ==  MALE)  ? 
"himself."   :  "herself."); 

else 

FIND_REL  (P1_INDEX,  P2_INDEX); 
else      /*  either  not  found  or  more  than  one  found  */ 
if  (P1_F0UND  ==  0) 

printf  ("  First  person  not  found. \n"); 
else  if  (P1_F0UND  >  1) 
{ 

printf  ("  Duplicate  names  for  first  person  -"); 
printf  ("  use  numeric  identif ier .\n" ) ; 

} 

if  (P2_F0UND  ==  0) 

printf  ("  Second  person  not  found.\n"); 
else  if  (P2_F0UND  >  1) 

{ 

printf  ("  Duplicate  names  for  second  person  -"); 
printf  ("  use  numeric  identif ier .\n") ; 

} 

}     /*  end  processing  of  syntactically  legal  request  */ 
else 

printf  ("  Incorrect  request  format:  %ls  \n" ,  ERR_MSG); 
}     /*  end  PROC_REQ  loop  */  ~ 
printf  ("  End  of  relation-finder.  \n"); 

} 

/*  End  of  main  line  of  RELATE  */ 
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/*  procedures  under  RELATE  »/ 


FXD  GETC  (RECEIVER,  SENDING,  GET  LEN) 


char 
FILE 
int 


•RECEIVER; 
•SENDING; 
GET  LEN; 


{  register  int  CHAR_CNT; 

for  (CHAR_CNT  =  0; 

CHAR_CNT++  <  GET_LEN  &&  (»RECEIVER++  =  getc  (SENDING))   ! =  EOF  ;   )  ; 
if  (CHAR_CNT  >=  GET_LEN) 
{ 

•RECEIVER  =  NULL_CHR; 
return  !EOF; 

} 

else 

return  EOF; 


STREQ  (STRING1,  STRING2) 

/•  compare  for  equality,  ignore  trailing  spaces  •/ 

register  char  •STRING  1 ,  •STRING2; 

{  register  char  •LONGER; 

for  (  ;  •STRING 1  ==  •STRING2;  STRING STRING2++) 
if  ( •STRING  1  ==  NULL_CHR) 
return  TRUE; 
if  ( •STRING 1  ==  NULL_CHR) 

LONGER  =  STRING2; 
else 

if  (•STRING2  ==  NULL_CHR) 

LONGER  =  STRING  1; 
else 

return  FALSE; 
for  (  ;  •LONGER++  =='';); 
return  (•—LONGER  ==  NULL_CHR); 

} 
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LINK_REL  (FROM_DEX,   REL_SHIP,  TO_INDEX) 

/*  establishes  cross- indexing  between  immediately  related  PERSONS.  */ 
register  INDXJTYP        FROM_DEX,  TO_INDEX; 
register  GIVEN_ID  REL_SHIP; 

{  /*  execution  of  LINK_REL  */ 
if  (REL_SHIP  ==  SPOUS_ID) 

{ 

LINK_ONE  (FROMJDEX,  SPOUSE,  TO_INDEX); 
LINK_ONE  (TO_INDEX,  SPOUSE,  FROM_DEX); 

} 

else      /*  REL_SHIP  is  father  or  mother  */ 

{ 

LINK_ONE  (FROMJDEX,   PARENT,  TO_INDEX); 
LIN-K_ONE  (TO_INDEX,  CHILD,  FROM_DEX); 

} 


LINK_ONE  (FROM_DEX,  THIS_EDG,  TO_INDEX) 

/*  Establishes  the  NBR_REC  from  one  PERSON  to  another  */ 

INDXJTYP  FROMJDEX,  TO_INDEX; 

EDGJTYPE  THIS_EDG; 

{  register  NBR_PTR  NEWJ^BR; 

NEW_NBR  =  (NBR_REC  *  )   calloc(l,   sizeof (NBR_REC ) ) ; 
NEW_NBR  ->  NBRJDEX      =  TO_INDEX; 
NEW_NBR  ->  NBR_EDGE     =  THIS_EDG; 

NEW_NBR  ->  NEXTJJBR     =  PERSON  [FROM_DEX]   .  NBRJIDR; 
PERSON  [FROM_DEX]   .  NBR_HDR  =  NEW_NBR; 

} 

PROMPT  (REQ_BUF) 

/*  Issues  prompt  for  user-request,  reads  in  request, 

blank-fills  buffer,  and  skips  to  next  line  of  input.  */ 

BUFJTYPE  REQ_BUF ; 

{ 

print f  ("  \n"); 

printf  (**  \n"); 

printf  ("  Enter  two  person-identifiers  (name  or  number) ,\n"); 
printf  ("  separated  by  semicolon.  Enter  \"stop\"  to  stop.\n"); 
fgets     (REQ_BUF,  BUFJ.EN,  stdin); 
for  (  ;  *REQJBUF-H-  !=  '\n'  ;   )  ; 
*~REQ  BUF  =  '\0'; 

} 


CHK_RQST  (REQ_BUF,  REQ_STAT) 

/*  Performs  syntactic  check  on  request  in  buffer.  */ 

BUFJTYPE  REQ_BUF; 
MSGJCYPE  REQ_STAT ; 

{  COUNTER  SEMI_LOC      =  1, 

SEMI_CNT      =  0; 
register  COUNTER  BUFJDEX; 

BOOLEAN  P1_EXIST  =  FALSE, 

P2_EXIST  =  FALSE; 

strcpy  (REQ_STAT,  REQJDK); 

for  (BUF_DEX  =  0;  BUF_DEX  <  BUF_LEN  &&  REQ_BUF   [BUF_DEX];  BUF_DEX-H-) 
{ 

if  (REQJBUF   [BUFJDEX]   !=  '  ') 
if  (REQ_BUF   [BUFJDEX]  ==  ';') 
{ 

SEMI_LOC  =  BUFJ)EX; 
SEMIj:NT        =  SEMIJCNT  +  1; 

} 

else      /*  Check  for  non-blanks  before/after  semicolon.  */ 
if  (SEMIJCNT  <  1) 

P1_EXIST  =  TRUE; 
else 

P2_EXIST  =  TRUE; 

} 

/*  set  REQ_STAT,  based  on  results  of  scan  of  REQ_BUF.  */ 
if  (SEMIJCNT  !=  1) 

strcpy  (REQ_STAT,  "must  be  exactly  one  semicolon."); 
else  if  (   !  Pl_EXIST) 

strcpy  (REQ_STAT,  "null  field  preceding  semicolon."); 
else  if  (   !  P2_EXIST) 

strcpy  (REQ_STAT,  "null  field  following  semicolon."); 
return  SEMIj:.OC; 

} 

ByF_PERS  (REQJ5UF,  BUFJ)EX,  PERS_ID) 

/*  fills  in  the  PERS_ID  from  the  designated  portion 
of  the  REQ_BUF,  deleting  leading  blanks.  */ 

BUFJTYPE  REQ_BUF ; 

register  COUNTER  BUFJDEX; 
NAME  TYP  PERS  ID; 


for  (  ;  REQJBUF  [BUFJ)EX++] 
strcpy  (PERS  ID,  &REQ_BUF  [ 


=='';); 

— BUF  DEX]  ); 
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SEEK_PER     (P1_IDENT,  P2_IDENT,  P1_INDEX,  P2_INDEX, 

P1_F0UND,  P2_F0UND) 
/»  SEEK_PER  scans  through  the  PERSON  array, 

looking  for  the  two  requested  PERSONS.  Match  may  be  by  NAME 
or  unique  IDENT-number.  »/ 

BUFJTYPE  P1_IDENT,  P2_IDENT; 

INDXJTYP  »P1_INDEX,  »P2_INDEX; 

COUNTER  »P1_F0UND,  »P2_F0UND; 

{  register  INDXJTYP  CURRENT; 

*P1_INDEX  =0; 
»P2_INDEX  =  0; 
»P1_F0UND  =  0; 
»P2_F0UND  =0; 
SCAN_PER : 

for  (CURRENT  =  0;  CURRENT  <  NUM  PERS;  CURRENT++) 
{ 

/•  allow  identification  by  name  or  number.  */ 
if  (STREQ  (P1_IDENT,  PERSON  [CURRENT]  .  IDENT)   I  I 
STREQ  (P1_IDENT,  PERSON  [CURRENT]  .  NAME)) 

{ 

(»P1_F0UND)++; 
»P1_INDEX  =  CURRENT; 

} 

if  (STREQ  (P2_IDENT,  PERSON  [CURRENT]  .  IDENT)   I  I 
STREQ  (P2_IDENT,  PERSON  [CURRENT]  .  NAME)) 

{ 

(»P2_F0UND)++; 
«P2_INDEX  =  CURRENT; 

} 

}    /»    end  SCAN_PER  loop  »/ 
}        /»  end  of  SEEK  PER  »/ 
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FIND_REL  (TARG_DEX,  SRCEJDEX) 

/*  Finds  shortest  path  (if  any)  between  two  PERSONS  and 
determines  their  REL_SHIP  based  on  immediate  relations 
traversed  in  path.    PERSON  array  simulates  a  directed  graph, 
and  algorithm  finds  shortest  path,  based  on  following 
weights:  PARENT-CHILD  edge    -  1.0 

SPOUSE -SPOUSE  edge  =  1.8  */ 

INDXJTYP 

{  register  INDXJTYP 
INDXJTYP 

register  NBR_PTR 
float 

typedef  short  int 
#define  SEARCHNG 
#define  SUCCESS 
//define  FAILED 

SRCHJTYP 

/*  begin  execution  of  FINDJREL  */ 

/*  initialize  PERSON-array  for  processing  - 

mark  all  nodes  as  not  seen  */ 
for  (PERSJ)EX  =  0;  PERSJDEX  <  NUM_PERS;  PERSJ)EX-H-) 

PERSON  [PERSJ)EX]   .  REACH_ST  =  NOT_SEEN; 
THIS_NOD  =  SRCEJ)EX; 
/*  mark  source  node  as  REACHED  */ 
PERSON  [THISJJOD]   .  REACH_ST  =  REACHED; 
PERSON  [THISJJOD]  .  DIST_SRC  =  0.0; 
/*  no  NEARBY  nodes  exist  yet  */ 
LSTJJRBY  =  -1; 

SRCH  ST    =  (THIS  NOD  =  TARGJ)EX)  ?  SUCCESS  :  SEARCHNG; 


TARGJDEX,  SRCEJDEX; 
PERSJ)EX; 

THISJJOD,  BESTJ)EX,  LSTJfRBY, 
NRBY_ND  [MAX_PERS]; 
THIS_NBR; 
MINJ)IST; 

SRCHJTYP; 

1 

2 

3 

SRCH  ST; 
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/*  Loop  keeps  processing  closest-to-source ,  unREACHED  node 
until  target  REACHED,  or  no  more  connected  nodes.  */ 
SEEKTARG: 

while  (SRCH_ST  ==  SEARCHNG) 

{     /*  Process  all  nodes  adjacent  to  THIS_NOD  */ 
for  (THIS_NBR  =  PERSON  [THIS_NOD]   .  NBR_HDR; 
THIS_NBR  !=  NULL; 
THIS_NBR  =  THISJJBR  ->  NEXT_NBR) 
PROC_ADJ  (THIS_NOD,   THIS_NBR  ->  NBR_DEX,  THIS_NBR  ->  NBR_EDGE, 
NRBY_ND,  &LST_NRBY); 

/*  All  nodes  adjacent  to  THIS_NOD  are  set.     Now  search  for 

shortest-distance  tinREACHED  (but  NEARBY)  node  to  process  next.  */ 

if  (LST_NRBY  ==  -1) 
SRCH_ST  =  FAILED; 

else      /*  determine  next  node  to  process  */ 
{ 

MIN_DIST  =  l.OE+18; 

for  (PERS_DEX  =  0;  PERSJDEX  <=  LST_NRBY;  PERS_DEX-++) 
if  (PERSON  [NRBY  ND   [PERS  DEX]]   .  DIST  SRC  <  MIN  DIST) 
{ 

BEST_DEX    =  PERS_DEX; 

MIN_DIST     =  PERSON  [NRBY_ND  [PERS_DEX] ]   .  DIST  SRC; 

} 

/*  establish  new  THISJJOD  */ 
THIS_NOD  =  NRBY_ND  [BEST_DEX]; 

/*  change  THISJJOD  from  being  NEARBY  to  REACHED  */ 
PERSON  [THIS_NOD]   .  REACH_ST  =  REACHED; 
/*  remove  THISJJOD  from  NEARBY  list  */ 
NRBY_ND   [BEST_DEX]   =  NRBYJID  [LSTJJRBY— ]; 
if  (THISJJOD  ==  TARGJDEX) 
SRCH_ST  =  SUCCESS; 

} 

}     /*    end  SEEKTARG  loop  */ 

/*  Shortest  path  between  PERSONS  now  established.     Next  task  is 

to  translate  path  to  English  description  of  REL_SHIP.  */ 
if  (SRCH_ST  ==  FAILED) 

printf  ("  %ls  is  not  related  to  %ls\n", 

PERSON  [TARGJ)EX]   .  NAME,   PERSON  [SRCE_DEX]   .  NAME); 
else      /*  success  -  parse  path  to  find  and  display  REL_SHIP  */ 
{ 

RESOLVE  (SRCEJ)EX,  TARGJ)EX); 
CMPT  GNS  (SRCE  DEX,  TARG  DEX); 

} 

}     /*  end  FIND  REL  */ 


/*  procedures  under  FIND_REL  */ 

PROC_ADJ  (BASENODE,   NXT_NODE ,   N_B_EDGE,   NRBY_ND,  LSTNRBY) 
/*  NXT_NODE  is  adjacent  to  last-REACHED  node  (==  BASENODE). 
If  NXT_NODE  already  REACHED,  do  nothing. 
If  previously  seen,  check  whether  path  thru  BASENODE  is 
shorter  than  current  path  to  NXT_NODE,  and  if  so  re-link 
next  to  base . 

If  not  previously  seen,  link  next  to  base  node.  */ 
register  INDXJTYP  NXT_NODE; 

INDXJTYP  BASENODE,  NRBY_ND[],  *LST_NRBY; 

EDGJTYPE  N_B_EDGE ; 

{  float  WGHT_EDG,  DIST_BAS; 

/*  begin  execution  of  PROC_ADJ  */ 
if  (PERSON  [NXT_NODE]   .  REACH_ST  !=  REACHED) 
{ 

WGHT_EDG  =  (N_B_EDGE  ==  SPOUSE)  ?  1.8  :  1.0; 
DIST_BAS  =  WGHT_EDG  +  PERSON  [BASENODE]   .  DIST_SRC; 
if  (PERSON  [NXT_NODE]   .  REACH_ST  ==  NOT_SEEN) 

{ 

PERSON  [NXT_NODE]   .  REACH_ST  =  NEARBY; 
NRBY_ND   [++  *LST_NRBY]  =  NXT_NODE ; 

/*  link  next  to  base  by  re-setting  its  predecessor  index  to 
point  to  base,  note  type  of  edge,  and  re-set  distance 
as  it  is  through  base  node.  */ 

PERSON   [NXT_NODE]   .  DIST_SRC  =  DIST_BAS; 

PERSON  [NXTJJODE]   .   PATHPRED  =  BASENODE; 

PERSON  [NXT_NODE  ]   .  EDG_PRED  =  N_B_EDGE ; 

} 

else      /*  REACH_ST  =  NEARBY  */ 

if  (DISTJBAS  <  PERSON  [NXTJJODE]   .  DIST_SRC) 

{     /*  link  next  to  base  by  re-setting  its  predecessor  index 
point  to  base,  note  type  of  edge,  and  re-set  distance 
as  it  is  through  base  node.  */ 
PERSON  [NXT_NODE]   .  DIST_SRC  =  DIST_BAS; 
PERSON  [NXTJJODE]   .   PATHPRED  =  BASENODE; 
PERSON  [NXT_NODE]   .  EDG_PRED  =  NJJDGE; 

} 

} 

}     /*  end  PROC  AD J  */ 
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RESOLVE  (SRCE_DEX,  TARGJDEX) 

/*  RESOLVE  condenses  the  shortest  path  to  a 

series  of  REL_SHIPs  for  which  there  are  English 
descriptions.  */ 

INDX_TYP  SRCE_DEX,  TARG_DEX; 

{  /*  these  variables  are  used  to  generate  KEY_PERSs  */ 

COUNTER  GEN_CNT; 

/*  these  variables  are  used  to  condense  the  path  */ 

KEY_REC  KEY_PERS   [MAX_PERS ] ; 

RELJTYPE  KEY_REL,  LKEY_REL,   PRIM_REL,  NXT_PRIM; 

register  INDXJTYP  KEY_DEX; 

INDXJTYP  LKEY_DEX,   PRIM_DEX,  THIS_NOD; 

BOOLEAN  SEEKMORE ; 


/*  begin  execution  of  RESOLVE  */ 

printf  ("  Shortest  path  between  identified  persons:  \n"); 
/*  Display  path  and  initialize  KEY_PERS  array  from  path  element 
TRAVERSE: 

for  (THIS_NOD     =  TARG_DEX,   KEY_DEX  =  0;  THIS_NOD  !=  SRCEJDEX; 
THIS_NOD    =  PERSON  [THIS_NOD]   .   PATHPRED,  KEY_DEX-H-) 

{ 

printf  ("  %ls  is  ",     PERSON  [THIS_NOD]  .  NAME); 
KEY_PERS   [KEY_DEX]   .   PERS_DEX  =  THIS_NOD; 
KEY_PERS   [KEY_DEX]   .   PROXIMTY  ==  FULL; 

KEY_PERS   [KEY_DEX]   .  REL_NEXT  =  PERSON  [THIS_NOD]   .  EDG_PRED 
switch  (PERSON  [THIS_NOD]   .  EDG_PRED) 
{ 

case  PARENT:  printf  ("parent  of\n"); 

KEY_PERS   [KEY_DEX]   .   GEN_GAP  =  1; 
break; 

case  CHILD  :   printf  ("child  of\n"); 

KEY_PERS   [KEYJDEX]   .   GEN_GAP  =  1; 
break; 

case  SPOUSE:  printf  ("spouse  of\n"); 

KEY_PERS   [KEY_DEX]   .   GEN_GAP  =  0; 
break; 

}     /*  end  switch  */ 
}     /*  end  TRAVERSE  loop  */ 
printf  ("  %ls\n",   PERSON  [THIS_NOD]   .  NAME); 
KEY_PERS   [KEY_DEX]  .   PERSJDEX  =  THIS_NOD; 

KEY_PERS   [KEY_DEX]  .  REL_NEXT  =  NULL_REL; 

KEY  PERS   [KEY  DEX  +  1]   .  REL  NEXT  =  NULL  REL; 
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/*  Resolve  CHILD-PARENT  and  CHILD-SPOUSE-PARENT  relations 
to  SIBLING  relations.  */ 
FIND_SIB: 

for  (KEYJDEX  =  0;  KEY_PERS   [KEY  DEX]   .  REL  NEXT  !=  NULL  REL;  KEY  DEX-H-) 

{  _  -  _  _ 

if  (KEY_PERS   [KEY_DEX]   .  REL  NEXT  ==  CHILD) 
{ 

LKEY_REL  =  KEY_PERS   [KEY_DEX  +  1]   .  REL_NEXT; 
If  (LKEY_REL  ==  PARENT) 

{       /*  found  either  full  or  half  SIBLINGS  */ 
BOOLEAN  FULL_SIB(); 

KEY_PERS   [KEY_DEX]   .   PROXIMTY  = 

FULL_SIB  (KEY_PERS   [KEY_DEX]  .  PERS_DEX, 

KEY_PERS   [KEY_DEX  +  2]   .  PERS_DEX) 
?  FULL  :  HALF; 

KEY_PERS   [KEY_DEX]   .  GEN_GAP    =  0; 

KEY_PERS   [KEY_DEX]   .  REL_NEXT  =  SIBLING; 

CONDENSE  (KEY_DEX,   1,  KEY_PERS); 

} 

else 

if  (LKEY_REL  ==  SPOUSE 

&&  KEY_PERS   [KEYJDEX  +  2]   .  REL_NEXT  ==  PARENT) 
{     /*  found  step-SIBLINGs  */ 
KEY_PERS   [KEY_DEX]   .  GEN_GAP    =  0; 
KEY_PERS   [KEY_DEX]  .   PROXIMTY  =  STEP; 
KEY_PERS   [KEYJDEX]   .  REL_NEXT  =  SIBLING; 
CONDENSE  (KEY_DEX,   2,  KEY_PERS ) ; 

} 

}     /*  end  if  RELJJEXT  ==  CHILD  */ 
}     /*    end  FIND_SIB  loop  */ 

/*  Resolve  CHILD-CHILD-. . .  and  PARENT-PARENT-. . .  relations  to 
direct  descendant  or  ancestor  relations.  */ 
FIND_ANC: 

for  (KEY_DEX  =  0;  KEY_PERS   [KEY_DEX]   .  REL_NEXT  !=  NULL_REL;  KEY_DEX-H-) 
{ 

if  (KEY_PERS   [KEY_DEX]   .  RELJJEXT  ==  CHILD   |  | 
KEY_PERS   [KEY_DEX]   .  REL_NEXT  ==  PARENT) 

{ 

for  (LKEY_DEX  =  KEYJDEX  +  1; 

KEYJPERS   [LKEY_DEX]   .  RELJJEXT  ==  KEYJ>ERS   [KEYJDEX]   .  RELJJEXT; 

LKEY_DEX-H-)  ; 
GENJ:NT  =  LKEYJDEX  -  KEYJDEX; 
if  (GENJJNT  >  1)      /*  compress  generations  */ 

{ 

KEYJ'ERS   [KEYJDEX]   .  GEN_GAP  =  GENJINT; 
CONDENSE  (KEY_DEX,   GENJ]NT  -  1,   KEY_PERS ) ; 

} 

}     /*    end  if  RELJJEXT  ==  CHILD  or  PARENT  */ 
}     /*    end  FIND  ANC  loop  */ 
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/*  Resolve  CHILD-SIBLING -PARENT  to  COUSIN, 
CHILD-SIBLING  to  NEPHEW, 

SIBLING -PARENT  to  UNCLE.  */ 

FIND_CUZ: 

for  (KEYJDEX  =  0;  KEY_PERS   [KEY_DEX]   .  REL_NEXT  !=  NULL_REL;  KEY_DEX-H-) 

{ 

LKEY_REL  =  KEY_PERS   [KEYJDEX  +  1]   .  REL_NEXT; 

if  (KEY_PERS   [KEY_DEX]   .  REL_NEXT  ==  CHILD  &&  LKEY_REL  ==  SIBLING) 
{     /*  COUSIN  or  NEPHEW  */ 
if  (KEY_PERS   [KEY_DEX  +  2]   .  REL_NEXr  ==  PARENT) 
{     /*  found  COUSIN  */ 
COUNTER  GAPl,  GAP2; 

GAPl  =  KEY_PERS   [KEY_DEX]  .  GEN_GAP; 

GAP2  =  KEYJPERS   [KEY_DEX  +  2]   .  GEN_GAP; 

KEY_PERS  [KEY_DEX]  .  PROXIMTY  =  KEY_PERS  [KEY_DEX  +  1]  .  PROXIMTY; 
KEY_PERS   [KEY_DEX]   .  GEN_GAP 

=  (GAPl  <  GAP2)  ?  (GAP2  -  GAPl)  :   (GAPl  -  GAP2); 
KEY_PERS   [KEY_DEX]   .  CUZ_RANK  =  (GAPl  <  GAP2)  ?  GAPl  :  GAP2; 
KEY_PERS   [KEYJDEX]   .   RELJ^EXT  =  COUSIN; 
CONDENSE  (KEY_DEX,   2,   KEY_PERS ) ; 

} 

else    /*  found  NEPHEW  */ 

{ 

KEY_PERS   [KEYJDEX]   .   PROXIMTY  =  KEYJ>ERS   [KEYJDEX  +  1]   .  PROXIMTY; 
KEY_PERS   [KEYJ)EX]   .  REL_NEXT  =  NEPHEW; 
CONDENSE  (KEYJDEX,   1,  KEYJ>ERS); 

} 

}     /*    end  COUSIN  or  NEPHEW  */ 
else 

if  (KEYJ>ERS   [KEYJDEX]   .  RELJJEXT  ==  SIBLING  &&  LKEYJIEL  ==  PARENT) 
{       /*  found  UNCLE  */ 

KEYJ>ERS   [KEYJDEX]   .  GENJSAP  =  KEYJ'ERS   [KEYJDEX  +  1]   .  GENJSAP; 
KEY_PERS   [KEY_DEX]   .  RELJJEXT  =  UNCLE; 
CONDENSE  (KEYJDEX,   1,  KEYJ'ERS); 

} 

}     /*     end  FIND  CUZ  loop  */ 
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/*  Loop  below  will  pick  out  valid  adjacent  strings  of  elements 
to  be  displayed.     KEY_DEX  points  to  first  element, 
LKEY_DEX  to  last  element,  and  PRIM_DEX  to  the 
element  which  determines  the  primary  English  word  to  be  used. 
Associativity  of  adjacent  elements  in  condensed  table 
is  based  on  English  usage.  */ 

printf  ("  Condensed  path:\n"); 
CONSLIDT : 

for  (KEYJDEX  =  0;  KEY_PERS   [KEY_DEX]   .  REL_NEXT  !=  NULL_REL; 
KEY  DEX  =  LKEY  DEX  +  1) 

{ 

KEY_REL    =  KEY_PERS   [KEY_DEX]   .  RELJIEXT; 
LKEY_DEX  =  KEY_DEX; 
PRIMJDEX  =  KEY_DEX; 

if  (KEY_PERS   [KEY_DEX  +  1]   .  REL_NEXT  !=  NULL_REL) 
{     /*  seek  multi-element  combination  */ 
SEEKMORE  =  TRUE; 
if  (KEY_REL  ==  SPOUSE) 

{ 

PRIMJDEX  =  -H-LKEY_DEX; 

/*  Nothing  can  follow  SPOUSE-SIBLING  or  SPOUSE-COUSIN  */ 

SEEKMORE  =  !   (KEY  PERS   [LKEY  DEX]   .  REL  NEXT  &  (SIBLING  I  COUSIN)); 
}  _  -  _ 

/*  PRIMJDEX  is  now  correctly  set.     Next  if-statement 
determines  if  a  following  SPOUSE  relation  should  be 
appended  to  this  combination  or  left  for  the  next 
combination.  */ 

if  (SEEKMORE  &&  KEY_PERS   [PRIM_DEX  +  1]   .  RELJJEXT  ==  SPOUSE) 
{     /*  Only  a  SPOUSE  can  follow  a  Primary; 

check  primary  preceding  and  following  SPOUSE.  */ 
PRIM_REL  =  KEY_PERS   [PRIM_DEX]  .  REL_NEXT; 

NXT_PRIM  =  KEY_PERS   [PRIM_DEX  +  2]   .  RELJJEXT; 
if  ((NXT_PRIM  &  (NEPHEW  |   COUSIN   I  NULL_REL)) 

I  I    (PRIM_REL  ==  NEPHEW) 

II  ((PRIM_REL  &  (SIBLING   |  PARENT))  &&  NXT_PRIM  !=  UNCLE  )) 
/*  append  following  SPOUSE  with  this  combination.  */ 
LKEY_DEX-H-; 

} 

}     /*  end  multi-element  combination  */ 
SHOW_REL  (KEYJDEX,  LKEY_DEX,   PRIM_DEX,  KEY_PERS); 
}     /*    end  CONSLIDT  loop  */ 
printf  ("  %ls\n",  PERSON  [KEYJ>ERS   [KEYJ)EX]   .   PERSJ)EX]   .  NAME); 
}     /*  end  of  RESOLVE  */ 
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BOOLEAN    FULL_SIB  (INDEXl,  INDEX2) 

/*  Determines  whether  two  PERSONS  are  full  siblings,  I.e., 

have  the  same  two  parents.  */ 
register  INDX  TYP      INDEXl,  INDEX2; 


{ 


} 


return 

!  STREQ  (PERSON  [INDEXl 
!  STREQ  (PERSON  [INDEXl 
STREQ  (PERSON  [INDEXl]  . 

PERSON  [INDEX2]  . 
STREQ  (PERSON  [INDEXl]  . 

PERSON  [INDEX2]  , 


.  REL_ID  [FATHR_ID],  NULL_ID)  && 

.  REL_ID   [MOTHR_ID]  ,  NULL_ID)  && 

REL_ID  [FATHR_ID], 

REL_ID  [FATHR_ID])  && 

REL_ID  [MOTHR_ID], 

REL  ID  [MOTHR  ID]); 


CONDENSE  (AT_INDEX,   GAP_SIZE,  KEY_PERS) 

/*  CONDENSE  condenses  superfluous  entries  from  the 
KEY  PERS  array,  starting  at  AT  INDEX.  */ 


register  INDXJIYP 

COUNTER 

KEY_REC 

{  register  INDXJTYP 

do 

{ 


AT_INDEX; 
GAP_SIZE; 
KEY_PERS  []; 

SEND  DEX; 


AT_INDEX-H-; 

SEND_DEX  =  AT_INDEX  +  GAP_SIZE; 

KEY_PERS   [AT_INDEX]  =  KEY_PERS  [SEND_DEX]; 

} 

while  (KEY  PERS   [SEND  DEX]   .  REL  NEXT  !=  NULL  REL); 
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/*  procedures  under  RESOLVE  */ 

SHOW_REL  (FRST_DEX,  1AST_DEX,   PRIM_DEX,  KEY_PERS) 

/*  SHOW_REL  takes  1,  2,  or  3  adjacent  elements  in  the 

condensed  table  and  generates  the  English  description  of 
the  relation  between  the  first  and  last  +  1  elements.  */ 


INDXJTYP 
KEY_REC 

BOOLEAN 

SIBJTYPE 

GNDRJTYP 

short  int 

register  REL_TYPE 

COUNTER 


FRST_DEX,  LAST_DEX,  PRIM_DEX; 
KEY_PERS  []; 

INLAW; 
THIS_PRX; 
THIS_GND; 
SUFFIX; 

FRST_REL,  LAST_REL,  PRIM_REL; 
THIS  GAP,  THIS  CUZ ; 


FRST_REL  =  KEY_PERS  [FRST_DEX]  .  REL_NEXT; 
LAST_REL  =  KEY_PERS  [LAST_DEX]  .  REL_NEXT; 
PRIM_REL  =  KEYJPERS   [PRIM_DEX]   .  REL_NEXT; 

/*  set  THIS_PRX  */ 

if  ((PRIM_REL  ==  PARENT  &&  FRST_REL  =  SPOUSE)  || 
(PRIM_REL  ==  CHILD     &&  LAST_REL    ==  SPOUSE)) 
THIS_PRX  =  STEP; 
else 

if  (PRIM_REL  &  (SIBLING   I  UNCLE   |  NEPHEW  I  COUSIN)) 

THIS_PRX  =  KEY_PERS   [PRIM_DEX]   .  PROXIMTY; 
else 

THIS_PRX  =  FULL; 
/*  set  THIS_GAP  */ 

if  (PRIM_REL  &  (PARENT   |  CHILD   |  UNCLE   I  NEPHEW  I  COUSIN)) 

THIS_GAP  =  KEY_PERS   [PRIM_DEX]   .  GEN_GAP; 
else 

THIS_GAP  =0; 

/*  set  INLAW  */ 
INLAW  =  FALSE; 

if  (FRST_REL  ==  SPOUSE  &&  (PRIM_REL  &  (SIBLING   |  CHILD   |  NEPHEW  I  COUSIN))) 

INLAW  =  TRUE; 
else 

if  (LAST_REL  ==  SPOUSE  && 

(PRIM_REL  &  (SIBLING   |  PARENT   |  UNCLE   |  COUSIN))) 
INLAW  =  TRUE; 

/*  set  THIS_CUZ  */ 

if  (PRIM_REL  ==  COUSIN) 

THIS_CUZ  =  KEY_PERS   [PRIM_DEX]   .  CUZ_RANK; 
else 

THIS  CUZ  =  0; 
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/*  parameters  are  set  -  now  generate  display.  */ 


printf  ("  %ls  is  ",   PERSON  [KEY  PERS   [FRST_DEX]   .   PERSJDEX]   .  NAME); 
if  (PRIM_REL  &  (PARENT   |  CHILD  T  UNCLE   |  NEPHEW)) 
{     /*  display  generation-qualifier  */ 
if  (THIS_GAP  >=  3) 
{ 

printf  ("great"); 
if  (THIS_GAP  >  3) 

printf  ("*%ld",  THIS_GAP  -  2); 
printf  ("-"); 

} 

if  (THIS_GAP  >=  2) 
printf  ("grand-"); 


if  (PRIM_REL  ==  COUSIN  &&  THIS_CUZ  >  1) 

{ 

printf  ("%ld",  THIS_CUZ); 
SUFFIX  =  THIS_CUZ  %  10; 
switch  (SUFFIX) 


} 

} 

if  (THIS_PRX  ==  STEP) 

printf  ("step-"); 
else 

if  (THIS_PRX  ==  HALF) 
printf  ("half-"); 


else 


case  1:  printf 

case  2:  printf 

case  3:  printf 

default:  printf 


("st  ") 

("nd  ") 

("rd  ") 

("th  ") 


break; 
break; 
break; 
break; 


THIS_GND  =  PERSON   [KEY_PERS   [FRST_DEX]   .   PERS_DEX]    .  GENDER 
switch  (PRIM_REL) 
{ 


case 

PARENT  : 

if  (THIS  GND  ==  MALE) 

printf  ( 

'  "father" ) ; 

else 

printf  ( 

[ "mother" ) ; 

break ; 

case 

CHILD  : 

if  (THIS  GND  ==  MALE) 

printf  ( 

'  "son" ) ; 

else 

printf  ( 

,  daughter  ); 

break:; 

case 

SPOUSE  : 

if  (THIS  GND  ==  MALE) 

printf  ( 

' "husband" ) ; 

else 

printf 

,  wife  ); 

break  j 

case 

SIBLING: 

if  (THIS  GND  ==  MALE) 

printf  ( 

,  brother  ) ; 

else 

printf  ( 

'  "sister" ) ; 

break ; 

case 

UNCLE  : 

J  £       /  Tin  X  O      O  XTTV  *jl  A  T  T?  \ 

ir   (THIS  GND  ==  MALE) 

printf 

,  uncle  ) ; 

else 

printf 

[ "aunt " ) ; 

break; 

case 

NEPHEW  : 

if  (THIS  GND  ==  MALE) 

printf  ( 

' "nephew" ) ; 

else 

printf  < 

^"niece" ) ; 

break; 

case 

COUSIN  : 

printf  ("cousin"); 
break; 

default  : 

printf  ("null"); 

break; 

} 

if  (INLAW) 

printf  ("-in-law"); 

if  (PRIM_REL  ==  COUSIN  &&  THIS_GAP  >  0) 
if  (THIS_GAP  >  1) 

printf  ("  %ld  times  removed",  THIS_GAP); 
else 

printf  ("  once  removed"); 

printf  ("  of\n"); 
/*  end  of  SHOW  REL  */ 
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/*  procedures  under  FIND_REL  */ 

CMPT_GNS  (INDEXl,  INDEX2) 

/*  CMPT_GNS  assumes  that  each  ancestor  contributes 

half  of  the  genetic  material  to  a  PERSON.     It  finds  common 
ancestors  between  two  PERSONS  and  computes  the  expected 
value  of  the  PROPORTN  of  common  material.  */ 

register  INDXJTYP      INDEXl,  INDEX2; 

{  float  COM_PROP; 

/*  First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 

because  there  might  be  two  paths  to  an  ancestor.  */ 
ZERO_PRO  (INDEXl); 

/*  now  mark  with  shared  PROPORTN  */ 

MARK_PRO  (PERSON   [INDEXl]   .  IDENT,   1.0,  INDEXl); 

COM_PROP  =0.0; 

CHK_COM  (  &  COM_PROP,   PERSON  [INDEXl]   .   IDENT,   1.0,   0.0,  INDEX2); 
printf  ("  Proportion  of  common  genetic  material  =  %1.5e  \n", 
COM_PROP); 
}     /*  end  of  CMPT_GNS  */ 

ZERO_PRO  (ZERO_DEX) 

/*  ZERO_PRO  recursively  seeks  out  all  ancestors  and 
zeros  them  out .  */ 

register  INDXJTYP  ZEROJDEX; 

{  register  NBR_PTR  THIS_NBR; 

PERSON  [ZERO_DEX]   .  DSC_GENE  =  0.0; 

for  (THIS_NBR  =  PERSON  [ZERO_DEX]   .  NBR_HDR; 

THIS_NBR  !=  NULL; 

THIS_NBR  =  THIS_NBR  ->  NEXT  NBR) 

{ 

if  (THIS_NBR  ->  NBR_EDGE  ==  PARENT) 
ZERO_PRO  (THIS  NBR  ->  NBR  DEX); 

} 

}     /*  end  of  ZERO  PRO  */ 


MARK_PRO  (MARKER,   PROPORTN,  MARK_DEX) 

/*  MARK_PRO  recursively  seeks  out  all  ancestors  and 
marks  them  with  the  sender's  PROPORTN  of  shared 
genetic  material.     This  PROPORTN  is  diluted  by  one-half 
for  each  generation.  */ 

IDJTYPE  MARKER; 
float  PROPORTN; 
INDXJTYP  MARK_DEX; 

{  register  NBR_PTR  THIS_NBR; 

strcpy  (PERSON  [MARKJDEX]   .  DSC_ID,  MARKER); 
PERSON  [MARK_DEX]   .  DSC_GENE  +=  PROPORTN; 
for  (THIS_NBR  =  PERSON  [MARK_DEX]   .  NBR_HDR; 

THIS_NBR  !=  NULL; 

THIS_NBR  =  THIS_NBR  ->  NEXT  NBR) 

{ 

if  (THISJJBR  ->  NBR_EDGE  ==  PARENT) 

MARK_PRO  (MARKER,   PROPORTN  /  2.0,  THIS  NBR  ->  NBR  DEX); 

} 

}     /*  end  of  MARK_PRO  */ 

CHK_COM  (COM_PTR,  MATCH_ID,   PROPORTN,  COUNTED,  CHKJDEX) 
/*  CHK_COM  searches  all  the  ancestors  of 

CHK_DEX  to  see  if  any  have  been  marked,  and  if  so 
adds  the  appropriate  amount  to  *COM_PTR.  */ 

float  *COM_PTR,   PROPORTN,  COUNTED; 

IDJTYPE  MATCH_ID; 
INDXJTYP  CHKJ)EX; 

{  register  NBR_PTR  THIS_NBR; 
register  float  CONTRIB; 

if  (STREQ  (PERSON  [CHK_DEX]   .  DSC_ID,  MATCH_ID)) 
{     /*  Increment  *COM_PTR  by  the  contribution  of 

this  common  ancestor,  but  discount  for  the  contribution 
of  less  remote  ancestors  already  counted.  */ 
CONTRIB  =  PERSON  [CHK_DEX]   .  DSC_GENE  *  PROPORTN; 
*COM  PTR  4=  CONTRIB  -  COUNTED; 

} 

else 

CONTRIB  =0.0; 
for  (THISJJBR  =  PERSON  [CHKJ)EX]   .  NBRJIDR; 

THIS_NBR  !=  NULL; 

THISJJBR  =  THISJJBR  ->  NEXTJJBR) 

{ 

if  (THISJJBR  ->  NBRJIDGE  ==  PARENT) 

CHKj:OM  (COM_PTR,  MATCH_ID,   PROPORTN  /  2.0, 

CONTRIB  /  4.0,  THISJJBR  ->  NBRJ)EX); 

} 

}     /*  end  of  CHK  COM  */ 
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5.0  COBOL 


In  keeping  with  the  general  convention  of  the  examples,  language- supplied 
keywords  and  identifiers  are  written  in  lower  case  in  the  program.  To  conform 
strictly  to  the  COBOL-74  standard,  however,  programs  must  use  only  upper-case 
letters . 


*    Compilation  unit  number  1   

identification  division, 
program- id.  RELATE. 

environment  division. 

configuration  section, 
source-computer.  VAX-11. 
object-computer.  VAX-11. 


input-output  section, 
file-control . 

select  PEOPLE  assign  to  "PEOPLE.DAT", 

file  status  is  PEOPLE -STATUS . 

data  division. 


file  section, 
fd  PEOPLE 

label  records  are  standard. 
01     PEOPLE -RECORD. 

05     NAME  pic  X(20). 

05     IDENTIFIER  pic  999. 

***  "M"  for  MALE  and  "F"  for  FEMALE 

05     GENDER  pic  X. 

05     IMMEDIATE -RELATIONS. 

10    RELATIVE -IDENTIFIER    occurs  3  times  pic  999. 

working-storage  section. 

77    ARG-PERSONl-INDEX  pic  999. 

77    ARG-PERS0N2 -INDEX  pic  999. 

01     PEOPLE -STATUS. 

05     STATUS -1  pic  X. 

88  END -OF -PEOPLE -FILE  value  "1". 

05     STATUS -2  pic  X. 


*    Define  global  objects 


01  TRUTH-VALUES. 

05     IS-TRUE  pic  X      value   "T" . 

05     IS-FALSE  pic  X      value  "F". 

01  SPECIAL-IDENT-VALUE. 

05     NULL-IDENT  pic  999  value  000. 


*  each  person's  record  in  the  file  identifies  at  most  three 

*  others  directly  related:  father,  mother,  and  spouse 
01  GIVEN-IDENTIFIERS. 


01 


05    FATHER-IDE NT 

pic 

9 

value 

1. 

05    MOTHER- IDENT 

pic 

9 

val  ue 

2. 

05  SPOUSE-IDENT 

pic 

9 

value 

3. 

GENDER -TYPE . 

05  MALE 

pic 

X 

value 

"M' 

05  FEMALE 

pic 

X 

value 

"F' 

T>T7T    A  T*  T  *^"M  T>\7TiT7 

RELAl ION— TYPE . 

05  PARENT 

pic 

9 

value 

1. 

05  CHILD 

pic 

9 

value 

2. 

05  SPOUSE 

pic 

9 

value 

3. 

05  SIBLING 

pic 

9 

value 

4. 

05  UNCLE 

pic 

9 

value 

5. 

05  NEPHEW 

pic 

9 

value 

6. 

05  COUSIN 

pic 

9 

value 

7. 

05    NULL -RELATION 

pic 

9 

value 

8. 

*  A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 

*  is  immediately  adjacent  to  those  reached,  or  farther  away. 
01  REACHED-TYPE. 

05    REACHED  pic  9      value  1. 

05    NEARBY  pic  9      value  2. 

05    NOT -SEEN  pic  9      value  3. 
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*  the  PERSON  array  is  the  central  repository  of  information 

*  about  inter-relationships. 

*  All  relationships  are  captured  in  the  directed  graph  of  which 

*  each  record  is  a  node . 
01  PERSON-TABLE. 

05    NUMBER-OF -PERSONS  usage  index. 

05    PERSON  occurs  300  times 

indexed  by  CURRENT,  PREVIOUS, 

FROM-INDEX,  TO-INDEX, 
PERSON  1-INDEX,  PERS0N2-INDEX. 
***    static  information  -  filled  from  PEOPLE  file: 
10    NAME  pic  X(20). 

10    IDENTIFIER  pic  999. 

10     GENDER  pic  X. 

***        IDENTIFIERS  of  immediate  relatives  -  father,  mother,  spouse 
10  IMMEDIATE-RELATIONS. 

15    RELATIVE -IDENTIFIER    occurs  3  times  indexed  by  RELATIONSHIP 

pic  999. 

***    pointers  to  immediate  neighbors  in  graph 
10    NEIGHBOR-COUNT  pic  99. 

10    NEIGHBOR-RECORD  occurs  20  times  indexed  by  NEXT -NEIGHBOR. 
15    NEIGHBOR-INDEX        usage  index. 
15    NEIGHBOR-EDGE  pic  9. 

***    data  used  when  traversing  graph  to  resolve  user  request: 

10    DI STANCE -FROM-SOURCE    pic  99999V9. 

10    PATH-PREDECESSOR  usage  index. 

10    EDGE-TO-PREDECESSOR      pic  9. 

10    REACHED-STATUS  pic  9. 

***    data  used  to  compute  common  genetic  material 

10    DESCENDANT -IDENTIFIER  pic  999. 

10    DESCENDANT -GENES  pic  9V99999999. 


*  These  variables  are  used  t 

*  RELATIONSHIP  information. 
01  RELATIONSHIP-WORK-ITEMS. 

05  REQUEST-BUFFER 

88  REQUEST-TO-STOP 
05  PERSONl-IDENT 
05  PERS0N2-IDENT 
05  PERSON 1 -FOUND 
05  PERS0N2-F0UND 
05  ERROR-MESSAGE 
05  REQUEST-OK 

01  AUXILIARY-VARIABLES. 
05  RELATION-LOOP-DONE 

88  RELATION-LOOP-IS 
05  TEMP-INDEX 
05    THIS -EDGE 
05  LEADING-SPACES 
05  SEMICOLON-COUNT 
05  CURRENT-IDENT 
05  PREVIOUS-IDENT 
05  TEMP-IDENT 


accept  and  resolve  requests  for 

pic  X(60). 
value  "stop", 
pic  X(20). 
pic  X(20). 
pic  999. 
pic  999. 
pic  X(40). 

pic  X(40)      value  "Request  OK". 


pic  X. 
•DONE      value  "T". 

usage  index, 
pic  9. 
pic  99. 
pic  99. 
pic  999. 
pic  999. 
pic  X(20). 
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procedure  division. 
MAIN-LINE. 

open  input  PEOPLE. 

read  PEOPLE  at  end  perform  NULL. 

*  This  loop  reads  in  the  PEOPLE  file  and  constructs  the  PERSON 

*  array  from  it  (one  PERSON  =  one  record  =  one  array  entry). 

*  As  records  are  read  in,  links  are  constructed  to  represent  the 

*  PARENT -CHILD  or  SPOUSE  RELATIONSHIP.     The  array  then  implements 

*  a  directed  graph  which  is  used  to  satisfy  subsequent  user 

*  requests.     The  file  is  assumed  to  be  correct  -  no  validation 

*  is  performed  on  it. 

perform  READ-IN-PEOPLE  thru  READ-IN-PEOPLE-EXIT 

varying  CURRENT  from  1  by  1  until  END-OF-PEOPLE-FILE. 
set  CURRENT  down  by  1. 
set  NUMBER-OF-PERSONS  to  CURRENT, 
close  PEOPLE. 

*  PERSON  array  is  now  loaded  and  edges  between  immediate  relatives 

*  (PARENT -CHILD  or  SPOUSE -SPOUSE)  are  established. 

perform  PROMPT -AND -RE AD. 

*  While-loop  accepts  requests  and  finds  RELATIONSHIP  (if  any) 

*  between  pairs  of  PERSONS. 

perform  READ-AND-PROCESS-REQUEST  thru  READ-AND-PROCESS-REQUEST-EXIT 

until  REQUEST-TO-STOP, 
display  "  End  of  relation-finder.", 
stop  run. 

READ-IN-PEOPLE. 
***    copy  direct  information  from  file  to  array 

move  corresponding  PEOPLE -RECORD  to  PERSON  (CURRENT), 
move  IMMEDIATE-RELATIONS  of  PEOPLE -RECORD 
to  IMMEDIATE -RELATIONS  of  PERSON  (CURRENT). 
***    Location  of  adjacent  persons  as  yet  undetermined 
move  zero  to  NEIGHBOR-COUNT  of  PERSON  (CURRENT). 
***    Descendants  as  yet  undetermined 

move  NULL-IDENT  to  DESCENDANT -IDENTIFIER  of  PERSON  (CURRENT), 
move  IDENTIFIER  of  PERSON  (CURRENT)  to  CURRENT-IDENT. 
***    Compare  this  PERSON  against  all  previously  entered  PERSONS 
***    to  search  for  RELATIONSHIPS. 

perform  COMPARE -TO-PREVIOUS  varying  PREVIOUS  from  1  by  1 

until  PREVIOUS  not  <  CURRENT, 
read  PEOPLE  at  end  perform  NULL. 
READ-IN-PEOPLE-EXIT. 
exit. 


NULL. 

exit . 
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COM PARE -TO -PREVIOUS . 

move  IDENTIFIER  of  PERSON  (PREVIOUS)  to  PREVIOUS -I DENT. 
***    Search  for  father,  mother,  or  spouse  relationship  in 
***    either  direction  between  this  and  PREVIOUS  PERSON. 
***    Assume  at  most  one  RELATIONSHIP  exists, 
move  IS-FALSE  to  RELATION-LOOP-DONE, 
perform  TRY -ALL -RELATION SHI PS 

varying  RELATIONSHIP  from  FATHER-IDENT  by  1 
until  RELATIONSHIP  >  SPOUSE-IDENT  or  RELATION-LOOP-IS-DONE. 
TRY -ALL -RELATIONSHIPS . 

if  RELATIVE -IDENTIFIER  of  PERSON  (CURRENT,  RELATIONSHIP)  = 
PREVIOUS-IDENT 
set  FROM-INDEX  to  CURRENT 
set  TO-INDEX      to  PREVIOUS 
perform  LINK-RELATIVES 
move  IS-TRUE  to  RELATION-LOOP-DONE 
else 

if  CURRENT-IDENT  = 

RELATIVE -IDENTIFIER  of  PERSON  (PREVIOUS,  RELATIONSHIP) 
set  FROM-INDEX  to  PREVIOUS 
set  TO-INDEX      to  CURRENT 
perform  LINK-RELATIVES 
move  IS-TRUE  to  RELATION-LOOP-DONE. 

LINK-RELATIVES. 

*  establishes  cross-indexing  between  immediately  related  PERSONS. 

if  RELATIONSHIP  =  SPOUSE-IDENT 

move  SPOUSE  to  THIS -EDGE 

perform  LINK-ONE -WAY 

set  TEMP-INDEX  to  FROM-INDEX 

set  FROM-INDEX  to  TO-INDEX 

set  TO-INDEX      to  TEMP-INDEX 

perform  LINK-ONE -WAY 
else 

*  RELATIONSHIP  is  father  or  mother 
move  PARENT  to  THIS -EDGE 
perform  LINK-ONE-WAY 

move  CHILD  to  THIS -EDGE 
set  TEMP-INDEX  to  FROM-INDEX 
set  FROM-INDEX  to  TO-INDEX 
set  TO-INDEX      to  TEMP-INDEX 
perform  LINK-ONE -WAY. 

LINK-ONE -WAY. 

***    Establishes  the  NEIGHBOR-RECORD  from  one  PERSON  to  another 
add     1  to  NEIGHBOR-COUNT  of  PERSON  (FROM-INDEX). 

set  NEXT -NEIGHBOR  to  NEIGHBOR-COUNT  of  PERSON  (FROM-INDEX). 
set  NEIGHBOR-INDEX  of  PERSON  (FROM-INDEX,  NEXT -NEIGHBOR) 

to  TO-INDEX. 
move  THIS-EDGE 

to  NEIGHBOR-EDGE     of  PERSON  (FROM-INDEX,  NEXT -NEIGHBOR) . 


PROMPT -AND -READ. 

*  Issues  prompt  for  user-request,  reads  In  request, 

*  blank-fills  buffer,  and  skips  to  next  line  of  input. 

display  "  ". 

display  "  ". 

display  "  Enter  two  person-identifiers  (name  or  number),", 
display  "  separated  by  semicolon.  Enter  ""stop""  to  stop.", 
move  spaces  to  REQUEST-BUFFER, 
accept  REQUEST-BUFFER. 

READ -AND - P RO CE S S -RE QUE S T . 
perform  CHECK-REQUEST. 

***    Syntax  check  of  request  completed.     Now  either  display  error 
***    message  or  search  for  the  two  PERSONS. 

if  ERROR-MESSAGE  =  REQUEST-OK 

perform  PROCESS-LEGAL -REQUEST 
else 

display  "  Incorrect  request  format:  ",  ERROR-MESSAGE, 
perform  PROMPT -AND -READ. 
READ-AND-PROCE S S -RE QUE  ST -E XI T . 
exit . 

CHECK-REQUEST. 

*  Performs  syntactic  check  on  request  in  buffer 

*  and  fills  in  identifiers  of  the  two  requested  persons. 

move  zero  to  SEMICOLON-COUNT. 

inspect  RE QUE ST -BUFFER  tallying  SEMICOLON -COUNT 

for  all  " ; " . 
if  SEMICOLON -COUNT  not  =  1 

move  "must  be  exactly  one  semicolon."  to  ERROR-MESSAGE 
else 

move  zero  to  LEADING-SPACES 

inspect  REQUEST-BUFFER  tallying  LEADING-SPACES 

for  leading  spaces 
add  1  to  LEADING -SPACES 

unstring  REQUEST-BUFFER  delimited  by  ";" 

into  PERSONl-IDENT,  TEMP-IDENT 

with  pointer  LEADING-SPACES 
if  PERSONl-IDENT  =  spaces 

move  "null  field  preceding  semicolon."  to  ERROR-MESSAGE 
else 

if  TEMP-IDENT  =  spaces 

move  "null  field  following  semicolon."  to  ERROR-MESSAGE 
else 

move  zero  to  LEADING -SPACES 

inspect  TEMP-IDENT  tallying  LEADING-SPACES 

for  leading  spaces 
add  1  to  LEADING -SPACES 
unstring  TEMP-IDENT  into  PERS0N2-IDENT 

with  pointer  LEADING -SPACES 
move  REQUEST-OK  to  ERROR-MESSAGE. 
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PROCE  SS -LEGAL-RE QUE  ST . 
***     search  for  requested  PERSONS. 

move  zero  to  PERSON 1-FOUND,  PERS0N2-F0UND. 

perform  SCAN-ALL-PERSONS  varying  CURRENT  from  1  by  1 

until  CURRENT  >  NUMBER-OF -PERSONS, 
if  PERSON 1-FOUND  =  1  and  PERSON 2 -FOUND  =  1 
***         Exactly  one  match  for  each  PERSON  -  proceed  to 
***  determine  RELATIONSHIP,  if  any. 

if  PERSONl-INDEX  =  PERS0N2-INDEX 

if  GENDER  of  PERSON  (PERSONl-INDEX)  =  MALE 

display  "  ",  NAME  of  PERSON  (PERSONl-INDEX), 
is  identical  to  himself." 

else 

display  "  ",  NAME  of  PERSON  (PERSONl-INDEX), 
is  identical  to  herself." 

else 

set  ARG-PERSONl-INDEX  to  PERSONl-INDEX 
set  ARG-PERS0N2-INDEX  to  PERS0N2-INDEX 
call  "FINDREL"  using 

ARG-PERSONl-INDEX,  ARG-PERS0N2-INDEX,  PERSON-TABLE 

else 

***  either  not  found  or  more  than  one  found 

perform  MISSING-OR-DUPLICATE -PERSONS . 

SCAN-ALL-PERSONS . 

if  PERSONl-IDENT  =  NAME  of  PERSON  (CURRENT)  or 

IDENTIFIER  of  PERSON  (CURRENT) 
set  PERSONl-INDEX  to  CURRENT 
add  1  to  PERSONl-FOUND. 
if  PERS0N2-IDENT  =  NAME  of  PERSON  (CLTIRENT)  or 

IDENTIFIER  of  PERSON  (CURRENT) 
set  PERS0N2-INDEX  to  CURRENT 
add  1  to  PERS0N2-F0UND. 

MISSING-OR-DUPLICATE-PERSONS. 
if  PERSONl-FOUND  =  zero 

display  "  First  person  not  found." 
else 

if  PERSONl-FOUND  >  1 

display  "  Duplicate  names  for  first  person  -  use", 
numeric  identifier.", 
if  PERS0N2-F0UND  =  zero 

display  "  Second  person  not  found." 
else 

if  PERS0N2-F0UND  >  1 

display  "  Duplicate  names  for  second  person  -  use" , 
numeric  identifier.". 
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*    Compilation  unit  number  2   

identification  division, 
program-id.  FINDREL. 

*  Finds  shortest  path  (if  any)  between  two  PERSONS  and 

*  determines  their  RELATIONSHIP  based  on  immediate  relations 

*  traversed  in  path.     PERSON  array  simulates  a  directed  graph, 

*  and  algorithm  finds  shortest  path,  based  on  following 

*  weights:  PARENT -CHILD  edge  =1.0 

*  SPOUSE -SPOUSE  edge  =  1.8 

environment  division. 

configuration  section, 
source-computer.  VAX-11. 
object-computer.  VAX-11. 

data  division, 
working-storage  section. 

*  Define  global  objects 

01  TRUTH-VALUES. 

05     IS-TRUE  pic  X      value  "T" . 

05     IS-FALSE  pic  X      value  "F". 

*  each  PERSON'S  record  in  the  file  identifies  at  most  three 

*  others  directly  related:  father,  mother,  and  spouse 
01  GIVEN-IDENTIFIERS. 


01 


05    FATHER-IDE NT 

pic 

9 

value 

1. 

05  MOTHER-IDENT 

pic 

9 

val  ue 

2. 

05     SPOUSE -I DENT 

pic 

9 

value 

3. 

GENDER -TYPE. 

05  MALE 

pic 

X 

value 

"M' 

05  FEMALE 

pic 

X 

value 

"F' 

RELATION-TYPE. 

05  PARENT 

pic 

9 

value 

1. 

05  CHILD 

pic 

9 

value 

2. 

05  SPOUSE 

pic 

9 

value 

3. 

05  SIBLING 

pic 

9 

value 

4. 

05  UNCLE 

pic 

9 

value 

5. 

05  NEPHEW 

pic 

9 

value 

6. 

05  COUSIN 

pic 

9 

value 

7. 

05     NULL -RELATION 

pic 

9 

value 

8. 
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*  A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 

*  is  immediately  adjacent  to  those  reached,  or  farther  away. 
01     REACHED-TYPE . 

05    REACHED  pic  9      value  1. 

05    NEARBY  pic  9      value  2. 

05     NOT -SEEN  pic  9      value  3. 


01  SEARCH-TYPE. 


05  SEARCHING 

pic 

9 

value 

1. 

05  SUCCEEDED 

pic 

9 

value 

2. 

05  FAILED 

pic 

9 

value 

3. 

SIBLING -TYPE. 

05  STEP 

pic 

9 

value 

1. 

05  HALF 

pic 

9 

value 

2. 

05  FULL 

pic 

9 

value 

3. 

01     KEY-PERSON -TABLE. 

05    KEY-PERSON    occurs  300  times 

indexed  by  KEY-INDEX,  LATER-KEY-INDEX,  PRIMARY-INDEX, 
FIRST-INDEX,  LAST-INDEX, 
RECEIVE -INDEX,  SEND-INDEX. 


10 

RELATION -TO -NEXT 

pic  9. 

10 

PERSON-INDEX 

usage  index. 

10 

GENERATION-GAP 

pic  999. 

10 

PROXIMITY 

pic  9. 

10 

COUSIN -RANK 

pic  999. 

01     AUXILIARY -VARIABLES. 

***    these  variables  are  used  to  find  the  shortest  path 

05    WEIGHT-THIS-EDGE  pic  99V9. 
05    DISTANCE -THRU -BASE -NODE       pic  99999V9. 

05     SEARCH-STATUS  pic  9. 

05    NEARBY-NODE  usage  index,     occurs  300  times, 

indexed  by  THIS-NEARBY-INDEX,  BEST-NEARBY-INDEX,  LAST -NEARBY -INDEX. 

05    THIS-EDGE  pic  9. 

05     NEXT-BASE -EDGE  pic  9. 

05    MINIMAL -DISTANCE  pic  9999999V9. 

05     DISPLAY -BUFFER  pic  X(70). 

05     DISPLAY-POINTER  pic  99. 

05     NULL-IDENT  pic  999     value  000. 

***     these  variables  are  used  to  condense  the  path 


05 

KEY-RELATION 

pic 

9. 

05 

LATER-KEY-RELATION 

pic 

9. 

05 

PRIMARY-RELATION 

pic 

9. 

05 

FIRST-RELATION 

pic 

9. 

05 

LAST-RELATION 

pic 

9. 

05 

NEXT -PRIMARY -RELATION 

pic 

9. 

05 

GAP-SIZE 

pic 

999. 

05 

ANOTHER-ELEMENT -POSSIBLE 

pic 

X. 

88  ANOTHER-ELEMENT-IS-POSSIBLE 

value  "T". 
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***    these  variables  are  used  to  generate  KEY-PERSONs  and  for  DISPLAY 


05 
05 
05 
05 
05 
05 
05 
05 
05 

05 


05 


05 


05 


GENERATION-COUNT 

TEMP -NUMBER 

THIS -COUSIN-RANK 

THIS -PROXIMITY 

THIS-GENDER 

THIS-GENERATION-GAP 

SUFFIX-INDICATOR 

TWO-DIGIT-FIELD 

INLAW 

88  RELATION-IS -INLAW 
MALE -NAME -VALUE  S . 


pic  999. 
pic  999. 
pic  999. 
pic  9. 
pic  X. 
pic  999. 
pic  9 . 
pic  Z9. 
pic  X. 


value  "T". 


10 

filler 

pic  X(8) 

value 

"father 

10 

filler 

pic  X(8) 

value 

"  son 

10 

filler 

pic  X(8) 

value 

"husband 

10 

filler 

pic  X(8) 

value 

"brother 

10 

filler 

pic  X(8) 

value 

"uncle 

10 

filler 

pic  X(8) 

value 

"nephew 

10 

filler 

pic  X(8) 

value 

"cousin 

10 

filler 

pic  X(8) 

value 

"null 

MALE -NAME -TABLE  redefines  MALE -NAME -VALUES. 
10  PRIMARY-MALE -NAME    pic  X(8)  occurs  8  times 

indexed  by  MALE-INDEX. 
FEMALE -NAME -VALUE S . 


10 

filler 

pic 

X(8) 

value 

"mother 

10 

filler 

pic 

X(8) 

value 

"daughter 

10 

filler 

pic 

X(8) 

value 

"wife 

10 

filler 

pic 

X(8) 

value 

"sister 

10 

filler 

pic 

X(8) 

value 

"aunt 

10 

filler 

pic 

X(8) 

value 

"niece 

10 

filler 

pic 

X(8) 

value 

"cousin 

10 

filler 

pic 

X(8) 

value 

"null 

FEMALE-NAME-TABLE  redefines  FEMALE -NAME -VALUES. 
10  PRIMARY -FEMALE -NAME     pic  X(8)  occurs  8  times 
indexed  by  FEMALE-INDEX. 
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linkage  section. 

77     PARM-TARGET-INDEX  pic  999. 

77     PARM-SOURCE-INDEX  pic  999. 

01  PERSON-TABLE. 

05     NUMBER-OF -PERSONS  usage  index. 

05    PERSON  occurs  300  times 

indexed  by  INDEXl,   INDEX2,  TARGET-INDEX,   SOURCE -INDEX, 
BASE -NODE,   THIS -NODE,  NEXT -NODE. 
***    static  information  -  filled  from  PEOPLE  file: 
10    NAME  pic  X(20). 

10    IDENTIFIER  pic  999. 

10     GENDER  pic  X. 

***        IDENTIFIERS  of  immediate  relatives  -  father,  mother,  spouse 
10     IMMEDIATE -RELATIONS. 

15    RELATIVE -IDENTIFIER    occurs  3  times  indexed  by  RELATIONSHIP 

pic  999. 

***     pointers  to  immediate  neighbors  in  graph 
10    NEIGHBOR-COUNT  pic  99. 

10     NEIGHBOR-RECORD  occurs  20  times  indexed  by  THIS -NEIGHBOR. 
15     NEIGHBOR-INDEX        usage  index. 
15     NEIGHBOR-EDGE  pic  9. 

***    data  used  when  traversing  graph  to  resolve  user  request: 

10    DISTANCE -FROM-SOURCE     pic  99999V9. 

10     PATH-PREDECESSOR  usage  index. 

10    EDGE-TO-PREDECESSOR      pic  9. 

10     REACHED-STATUS  pic  9. 

***    data  used  to  compute  common  genetic  material 

10     DESCENDANT-IDENTIFIER  pic  999. 

10     DESCENDANT-GENES  pic  9V99999999. 

procedure  division  using 

PARM-TARGET-INDEX,   PARM-SOURCE-INDEX,  PERSON-TABLE. 

MAIN-LINE. 

set  TARGET -INDEX  to  PARM-TARGET-INDEX. 

set  SOURCE-INDEX  to  PARM-SOURCE-INDEX. 
***     initialize  PERSON-array  for  processing  - 
***    mark  all  nodes  as  not  seen 

perform  MARK-AS-NOT-SEEN  varying  THIS-NODE  from  1  by  1 
until  THIS-NODE  >  NUMBER-OF-PERSONS. 

set  THIS-NODE  to  SOURCE -INDEX. 
***    mark  source  node  as  REACHED 

move  REACHED  to  REACHED-STATUS  of  PERSON  (THIS-NODE). 

move  zero        to  DISTANCE -FROM-SOURCE  of  PERSON  (THIS-NODE). 
***    no  nearby  nodes  exist  yet 

set  LAST-NEARBY-INDEX  to  1. 

set  LAST-NEARBY-INDEX  down  by  1. 

if  THIS-NODE  =  TARGET-INDEX 

move  SUCCEEDED  to  SEARCH-STATUS 

else 

move  SEARCHING  to  SEARCH-STATUS. 


***    Loop  keeps  processing  closest-to-source ,  unREACHED  node 
***     until  target  REACHED,  or  no  more  connected  nodes. 

perform  SEARCH-FOR-TARGET  until  SEARCH-STATUS  not  =  SEARCHING. 

Shortest  path  between  PERSONS  now  established.     Next  task  is 
to  translate  path  to  English  description  of  RELATIONSHIP, 
if  SEARCH-STATUS  =  FAILED 

display  "  " ,  NAME  of  PERSON  (TARGET-INDEX) ,  "  is  not  related  to  ", 
NAME  of  PERSON  (SOURCE -INDEX) 

else 

success  -  parse  path  to  find  and  display  RELATIONSHIP 
perform  RESOLVE-PATH-TO-ENGLISH 
call  "COMGENES"  using 

PARM-SOURCE -INDEX,   PARM-TARGET-INDEX,  PERSON-TABLE. 
OF-FINDREL. 
exit  program. 

MARK-AS-NOT-SEEN. 

move  NOT-SEEN  to  REACHED-STATUS  of  PERSON  (THIS-NODE). 

SEARCH-FOR-TARGET. 
***    Process  all  nodes  adjacent  to  THIS-NODE 

perform  PROCESS-ADJACENT -NODE  varying  THIS-NEIGHBOR  from  1  by  1 
until  THIS-NEIGHBOR  >  NEIGHBOR-COUNT  of  PERSON  (THIS-NODE). 
***    All  nodes  adjacent  to  THIS-NODE  are  set.     Now  search  for 
***    shortest-distance  unREACHED  (but  NEARBY)  node  to  process  next, 
if  LAST-NEARBY-INDEX  =  zero 

move  FAILED  to  SEARCH-STATUS 
else 

***         determine  next  node  to  process 

move  9999999  to  MINIMAL -DISTANCE 

perform  FIND-CLOSEST-UNREACHED-NODE  varying  THIS-NEARBY-INDEX 
from  1  by  1  until  THIS-NEARBY-INDEX  >  LAST-NEARBY-INDEX 

***         establish  new  THIS-NODE 

set  THIS-NODE  to  NEARBY-NODE  (BE ST -NEARBY-INDEX) 
***         change  THIS-NODE  from  being  NEARBY  to  REACHED 

move  REACHED  to  REACHED-STATUS  of  PERSON  (THIS-NODE) 
***  remove  THIS-NODE  from  NEARBY  list 

set  NEARBY-NODE  (BEST-NEARBY-INDEX)  to  NEARBY-NODE  (LAST-NEARBY-INDEX) 

set  LAST -NEARBY-INDEX  down  by  1 

if  THIS-NODE  =  TARGET-INDEX 

move  SUCCEEDED  to  SEARCH-STATUS. 
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PROCESS-ADJACENT-NODE . 

set  BASE -NODE  to  THIS-NODE. 

set  NEXT -NODE  to  NEIGHBOR-INDEX  of  PERSON  (BASE -NODE,  THIS -NEIGHBOR) . 

move  NEIGHBOR-EDGE  of  PERSON  (BASE -NODE,  THIS-NEIGHBOR) 
to  NEXT -BASE -EDGE. 
***    NEXT -NODE  is  adjacent  to  last-REACHED  node  (=  BASE-NODE). 
***    if  NEXT -NODE  already  REACHED,  do  nothing. 
***    If  previously  seen,  check  whether  path  thru  BASE -NODE  is 
***    shorter  than  current  path  to  NEXT -NODE,  and  if  so  re-link 
***    next  to  base. 

***    If  not  previously  seen,  link  next  to  base  node, 
if  NEXT-BASE-EDGE  =  SPOUSE 

move  1.8  to  WEIGHT-THIS-EDGE 
else 

move  1.0  to  WEIGHT-THIS-EDGE. 
if  REACHED-STATUS  of  PERSON  (NEXT-NODE)  not  =  REACHED 

add  WEIGHT-THIS-EDGE,   DISTANCE-FROM-SOURCE  of  PERSON  (BASE -NODE) 

giving  DISTANCE -THRU-BASE -NODE 
if  REACHED-STATUS  of  PERSON  (NEXT-NODE )  =  NOT -SEEN 

move  NEARBY  to  REACHED-STATUS  of  PERSON  (NEXT -NODE) 
set  LAST-NEARBY-INDEX  up  by  1 

set  NEARBY-NODE  (LAST-NEARBY-INDEX)   to  NEXT -NODE 
perform  LINK-NEXT -NODE -TO-BASE-NODE 
else 

***  REACHED-STATUS  =  NEARBY 

if  DISTANCE-THRU-BASE-NODE 

<  DISTANCE-FROM-SOURCE  of  PERSON  (NEXT -NODE) 
per  f  orm  L INK-NE XT -NODE -TO -BASE -NODE . 

LINK-NEXT -NODE -TO-BASE-NODE . 
***    link  next  to  base  by  re-setting  its  predecessor  index  to 
***    point  to  base,  note  type  of  edge,  and  re-set  distance 
***    as  it  is  through  base  node, 
move  DISTANCE-THRU-BASE-NODE 

to  DISTANCE-FROM-SOURCE  of  PERSON  (NEXT-NODE), 
set  PATH-PREDECESSOR  of  PERSON  (NEXT -NODE)   to  BASE -NODE, 
move  NEXT -BASE -EDGE  to  EDGE-TO-PREDECESSOR  of  PERSON  (NEXT -NODE ) . 

FIND -CLOSEST-UNREACHED -NODE. 

set  NEXT -NODE  to  NEARBY-NODE   (THIS-NEARBY-INDEX) . 
if  DISTANCE-FROM-SOURCE  of  PERSON  (NEXT -NODE)  <  MINIMAL -DISTANCE 
set  BEST-NEARBY-INDEX  to  THIS-NEARBY-INDEX 

move  DISTANCE-FROM-SOURCE  of  PERSON  (NEXT-NODE)   to  MINIMAL-DISTANCE. 
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RESOLVE-PATH-TO-ENGLISH. 
***    RESOLVE-PATH-TO-ENGLISH  condenses  the  shortest  path  to  a 
***     series  of  RELATIONSHIPS  for  which  there  are  English 
***  descriptions. 

***    Key  persons  are  the  ones  in  the  RELATIONSHIP  path  which  remain 
***    after  the  path  is  condensed. 

display  "  Shortest  path  between  identified  persons:  ". 
set  THIS-NODE  to  TARGET-INDEX. 
***    Display  path  and  initialize  KEY-PERSON  array  from  path  elements, 
perform  TRAVERSE-SHORTEST-PATH  varying  KEY-INDEX  from  1  by  1 

until  THIS-NODE  =  SOURCE-INDEX, 
display  "  ",  NAME  of  PERSON  (THIS-NODE). 
set  PERSON-INDEX  of  KEY-PERSON  (KEY-INDEX)  to  THIS-NODE. 
move  NULL -RELATION  to  RELATION -TO -NEXT  of  KEY-PERSON  ( KEY -INDEX ) . 
move  NULL-RELATION  to  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX  +  1). 

***    Resolve  CHILD-PARENT  and  CHILD -SPOUSE -PARENT  relations 
***    to  SIBLING  relations. 

perform  FIND-SIBLINGS  varying  KEY-INDEX  from  1  by  1 

until  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  NULL-RELATION. 

***    Resolve  CHILD-CHILD-...  and  PARENT-PARENT-...  relations  to 
***    direct  descendant  or  ancestor  relations. 

perform  FIND-ANCESTORS-OR-DESCENDANTS  varying  KEY-INDEX  from  1  by  1 
until  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  NULL -RELATION. 

***  Resolve  CHILD-SIBLING-PARENT  to  COUSIN, 
***  CHILD-SIBLING  to  NEPHEW, 

***  SIBLING-PARENT  to  UNCLE. 

perform  FIND-COUSINS-NEPHEWS-UNCLES  varying  KEY-INDEX  from  1  by  1 
until  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  NULL -RELATION. 


***      Loop  below  will  pick  out  valid  adjacent  strings  of  elements 

***      to  be  displayed.     KEY-INDEX  points  to  first  element, 

***      LATER-KEY-INDEX  to  last  element,  and  PRIMARY-INDEX  to  the 

***      element  which  determines  the  primary  English  word  to  be  used. 

***      Associativity  of  adjacent  elements  in  condensed  table 

***      is  based  on  English  usage. 

set  KEY-INDEX  to  1. 

display  "  Condensed  path:". 

perform  CONSOLIDATE -ADJACENT-PERSONS 

until  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  NULL -RELATION 

set  THIS-NODE  to  PERSON-INDEX  of  KEY-PERSON  (KEY-INDEX). 

display  "  ",  NAME  of  PERSON  (THIS-NODE). 
***      end  of  RESOLVE-PATH-TO-ENGLISH 
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TRAVERSE -S HORTE ST-PATH . 

set  PERSON-INDEX  of  KEY-PERSON  (KEY-INDEX)  to  THIS-NODE. 
move  FULL  to  PROXIMITY  of  KEY-PERSON  (KEY-INDEX) . 
move  EDGE-TO-PREDECESSOR  of  PERSON  (THIS-NODE) 

to  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX) . 
if  EDGE-TO-PREDECESSOR  of  PERSON  (THIS-NODE)  =  SPOUSE 

move  zero  to  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 
display  "        NAME  of  PERSON  (THIS-NODE),  "  is  spouse  of" 

else 

move  1  to  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 
if  EDGE-TO-PREDECESSOR  of  PERSON  (THIS-NODE)  =  PARENT 

display  "  " ,  NAME  of  PERSON  (THIS-NODE),  "  is  parent  of" 
else 

**  edge  is  child-type 

display  "  ",  NAME  of  PERSON  (THIS-NODE),  "  is  child  of", 
set  THIS-NODE  to  PATH-PREDECESSOR  of  PERSON  (THIS-NODE). 

FIND-SIBLINGS. 

if  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  CHILD 
move  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX  +  1) 

to  LATER-KEY-RELATION 
if  LATER-KEY-RELATION  =  PARENT 
**  then  found  either  full  or  half  SIBLINGS 

perform  SET -UP -FULL -HALF -SIB LING 
else 

if  LATER-KEY-RELATION  =  SPOUSE  and 

RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX  +  2)  =  PARENT 
**  then  found  step-siblings 

move  zero  to  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 
move  STEP        to  PROXIMITY  of  KEY-PERSON  (KEY-INDEX) 

move  SIBLING  to  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX) 
move  2  to  GAP-SIZE 
perform  CONDENSE-KEY-PERSONS. 

SET -UP-FULL -HALF-SIBLING. 

■**        Determines  whether  two  PERSONS  are  full  siblings,  i.e., 
'**        have  the  same  two  parents . 

set  INDEXl  to  PERSON-INDEX  of  KEY-PERSON  (KEY-INDEX), 
set  INDEX2  to  PERSON-INDEX  of  KEY-PERSON  (KEY-INDEX  +  2). 
if  (NULL-IDENT  not  = 

RELATIVE -IDENTIFIER  of  PERSON  (INDEXl,  FATHER-IDENT) 
and  RELATIVE-IDENTIFIER  of  PERSON  (INDEXl,  MOTHER-IDENT) ) 
and  (RELATIVE-IDENTIFIER  of  PERSON  (INDEXl,  FATHER-IDENT)  = 

RELATIVE -IDENTIFIER  of  PERSON  (INDEX2,  FATHER-IDENT)) 
and  (RELATIVE -IDENTIFIER  of  PERSON  (INDEXl,  MOTHER-IDENT)  = 
RELATIVE-IDENTIFIER  of  PERSON  (INDEX2,  MOTHER-IDENT)) 
move  FULL  to  PROXIMITY  of  KEY-PERSON  (KEY-INDEX) 
else 

move  HALF  to  PROXIMITY  of  KEY-PERSON  (KEY-INDEX), 
move  zero        to  GENERATION-GAP      of  KEY-PERSON  (KEY-INDEX), 
move  SIBLING  to  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX), 
move  1  to  GAP-SIZE, 
perform  CONDENSE-KEY-PERSONS. 
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FIND-ANCESTORS-OR-DES CENDANT S. 

if  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  CHILD  or  PARENT 
perform  NULL  varying  LATER-KEY -INDEX  from  KEY-INDEX  by  1 

until  RELATION-TO-NEXT  of  KEY-PERSON  (LATER-KEY-INDEX)  not  = 
RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX) 
set  GENERATION-COUNT  to  LATER-KEY-INDEX 
set  TEMP-NUMBER  to  KEY-INDEX 

subtract  TEMP-NUMBER  from  GENERATION-COUNT 
if  GENERATION -COUNT  >  1 
***  compress  generations 

move  GENERATION-COUNT  to  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 
subtract  1  from  GENERATION-COUNT  giving  GAP-SIZE 
perform  CONDENSE -KEY-PERSONS. 

FIND -COUSINS-NEPHEWS-UNCLES. 

move  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX  +  1) 

to  LATER-KEY-RELATION 
if  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  CHILD  and 
LATER-KEY -RELATION  =  SIBLING 
***     then  COUSIN  or  NEPHEW 

if  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX  +  2)  =  PARENT 

perform  FOUND-COUSIN 
else 

***  found  NEPHEW 

move  PROXIMITY  of  KEY-PERSON  (KEY-INDEX  +  1)  to 

PROXIMITY  of  KEY-PERSON  (KEY-INDEX) 
move  NEPHEW  to  RELATION -TO -NEXT  of  KEY-PERSON  (KEY-INDEX) 
move  1  to  GAP-SIZE 
perform  CONDENSE-KEY-PERSONS 

else 

if  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  =  SIBLING  and 
LATER-KEY-RELATION  =  PARENT 
***  then  found  UNCLE 

move  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX  +  1)  to 

GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 
move  UNCLE  to  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX) 
move  1  to  GAP-SIZE 
perform  CONDENSE-KEY-PERSONS. 
FOUND-COUSIN. 

if  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 

<  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX  +  2) 
move  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX) 
to  COUSIN-RANK  of  KEY-PERSON  (KEY-INDEX) 

else 

move  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX  +  2) 
to  COUSIN-RANK  of  KEY-PERSON  (KEY-INDEX) . 
***    subtract  moves  in  absolute  value  since  GENERATION-GAP  is  unsigned 
subtract  GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX  +  2) 

from    GENERATION-GAP  of  KEY-PERSON  (KEY-INDEX), 
move  PROXIMITY  of  KEY-PERSON  (KEY-INDEX  +  1) 

to  PROXIMITY  of  KEY-PERSON  (KEY-INDEX), 
move  COUSIN  to  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX) . 
move  2  to  GAP-SIZE, 
perform  CONDENSE-KEY-PERSONS. 
NULL. 

exit . 
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CONDENSE -KEY-PERSONS. 
***        CONDENSE -KEY-PERSONS  condenses  superfluous  entries  from  the 
***        KEY-PERSON  array,  starting  at  KEY-INDEX. 

set  RECEIVE-INDEX  to  KEY-INDEX. 

set  RECEIVE-INDEX  up  by  1. 

set  SEND-INDEX  to  RECEIVE-INDEX. 

set  SEND-INDEX  up  by  GAP-SIZE. 

perform  SLIDE -IT-DOWN  varying  RECEIVE-INDEX  from  RECEIVE-INDEX  by  1 
until  RELATION-TO-NEXT  of  KEY-PERSON  (RECEIVE-INDEX  -  1) 
=  NULL -RELATION. 
SLIDE-IT-DOWN. 

move  KEY-PERSON  (SEND-INDEX)  to  KEY-PERSON  (RECEIVE-INDEX). 
set  SEND-INDEX  up  by  1. 

CONSOLIDATE-ADJACENT -PERSONS. 

move  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX)  to  KEY-RELATION, 
set  LATER-KEY-INDEX,   PRIMARY-INDEX  to  KEY-INDEX. 

if  RELATION-TO-NEXT  of  KEY-PERSON  (KEY-INDEX  +  1)  not  =  NULL-RELATION 

perform  SEEK-MULTI -ELEMENT -COMBINATION, 
set  FIRST-INDEX  to  KEY-INDEX, 
set  LAST-INDEX  to  LATER-KEY-INDEX, 
perform  DISPLAY-RELATION, 
set  KEY-INDEX  to  LATER-KEY-INDEX, 
set  KEY-INDEX  up  by  1. 


SEEK-MULTI -ELEMENT -COMB I NATION. 

move  IS-TRUE  to  ANOTHER-ELEMENT -POSSIBLE, 
if  KEY-RELATION  =  SPOUSE 

set  LATER-KEY-INDEX  up  by  1 
set  PRIMARY-INDEX  up  by  1 

if  RELATION-TO-NEXT  of  KEY-PERSON  (LATER-KEY-INDEX) 

=  SIBLING  or  COUSIN 
then  nothing  can  follow  spouse-sibling  or  spouse-cousin 
move  IS-FALSE  to  ANOTHER-ELEMENT-POSSIBLE. 
PRIMARY-INDEX  is  now  correctly  set.     Next  if-statement 
determines  if  a  following  SPOUSE  relation  should  be 
appended  to  this  combination  or  left  for  the  next 
combination . 

if  RELATION-TO-NEXT  of  KEY-PERSON  (PRIMARY-INDEX  +  1)  =  SPOUSE 
and  ANOTHER-ELEMENT-IS-POSSIBLE 
Only  a  SPOUSE  can  follow  a  Primary 
check  primary  preceding  and  following  SPOUSE, 
move  RELATION-TO-NEXT  of  KEY-PERSON  (PRIMARY-INDEX) 

to  PRIMARY-RELATION 
move  RELATION-TO-NEXT  of  KEY-PERSON  (PRIMARY -INDEX  +  2) 

to  NEXT-PRIMARY-RELATION 
if  (NEXT -PRIMARY-RELATION  =  NEPHEW  or  COUSIN  or  NULL-RELATION) 
or  (PRIMARY -RELATION  =  NEPHEW) 
or  (   (PRIMARY-RELATION  =  SIBLING  or  PARENT) 

and  NEXT-PRIMARY-RELATION  not  =  UNCLE  ) 
then  append  following  SPOUSE  with  this  combination, 
set  LATER-KEY-INDEX  up  by  1. 


*** 

icifk 
*** 
*** 
*** 


*** 
*** 


*** 
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DISPLAY-RELATION. 
***    DISPLAY-RELATION  takes  1,   2,  or  3  adjacent  elements  in  the 
***     condensed  table  and  generates  the  English  description  of 
***     the  relation  between  the  first  and  last  +  1  elements. 

move  RELATION-TO-NEXT  of  KEY-PERSON  (FIRST-INDEX) 

to  FIRST-RELATION, 
move  RELATION -TO-NEXT  of  KEY-PERSON  (LAST-INDEX) 

to  LAST-RELATION, 
move  RELATION-TO-NEXT  of  KEY-PERSON  (PRIMARY -INDEX) 
to  PRIMARY -RELATION. 
***     set  THIS -PROXIMITY 

if  (PRIMARY -RELATION  =  PARENT  and  FIRST-RELATION  =  SPOUSE)  or 
(PRIMARY -RELATION  =  CHILD    and  LAST-RELATION     =  SPOUSE) 
move  STEP  to  THIS -PROXIMITY 
else 

if  PRIMARY-RELATION  =  SIBLING  or  UNCLE  or  NEPHEW  or  COUSIN 

move  PROXIMITY  of  KEY-PERSON  (PRIMARY -INDEX)  to  THIS -PROXIMITY 
else 

move  FULL  to  THIS -PROXIMITY. 
***    set  THIS -GENERATION-GAP 

if  PRIMARY -RELATION  =  PARENT  or  CHILD  or  UNCLE  or  NEPHEW  or  COUSIN 
move  GENERATION-GAP  of  KEY-PERSON  (PRIMARY-INDEX) 
to  THIS -GENERATION -GAP 

else 

move  zero  to  THIS-GENERATION-GAP. 
***    set  INLAW 

if  (FIRST-RELATION  =  SPOUSE)  and 

(PRIMARY -RELATION  =  SIBLING  or  CHILD  or  NEPHEW  or  COUSIN) 
move  IS -TRUE  to  INLAW 
else 

if  (LAST-RELATION  =  SPOUSE)  and 

(PRIMARY-RELATION  =  SIBLING  or  PARENT  or  UNCLE  or  COUSIN) 

move  IS -TRUE  to  INLAW 
else 

move  IS -FALSE  to  INLAW. 
***     set  THIS-COUSIN-RANK 

if  PRIMARY-RELATION  =  COUSIN 

move  COUSIN-RANK  of  KEY-PERSON  (PRIMARY-INDEX)  to  THIS-COUSIN-RANK 
else 

move  zero  to  THIS-COUSIN-RANK. 
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***    parameters  are  set  -  now  generate  display. 

set  THIS-NODE  to  PERSON-INDEX  of  KEY-PERSON  (FIRST-INDEX), 
move  spaces  to  DISPLAY-BUFFER, 
move  1  to  DISPLAY-POINTER. 

string  "  ",  NAME  of  PERSON  (THIS-NODE),  "  Is  " 
delimited  by  size 

Into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER. 
If  PRIMARY -RELATION  =  PARENT  or  CHILD  or  UNCLE  or  NEPHEW 

perform  GENERATE-GENERATION-QUALIFIER 
else 

If  (PRIMARY-RELATION  =  COUSIN)  and  (THIS-COUSIN-RANK  >  1) 
move  THIS-COUSIN-RANK  to  IWO-DIGIT-FIELD 

string  TWO-DIGIT-FIELD  delimited  by  size  into  DISPLAY-BUFFER 

with  pointer  DISPLAY-POINTER 
divide  THIS-COUSIN-RANK  by  10  giving  TEMP-NUMBER 

remainder  SUFFIX-INDICATOR 
if  SUFFIX-INDICATOR  =  1 

string  "st  "  delimited  by  size 

Into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 
else  if  SUFFIX-INDICATOR  =  2 

string  "nd  "  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 
else  if  SUFFIX-INDICATOR  =  3 

string  "rd  "  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 

else 

string  "th  "  delimited  by  size 

into  DISPLAY -BUFFER  with  pointer  DISPLAY-POINTER. 

if  THIS-PROXIMITY  =  STEP 

string  "step-"  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 

else 

if  THIS-PROXIMITY  =  HALF 

string  "half-"  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER. 

set  THIS-NODE  to  PERSON-INDEX  of  KEY-PERSON  (FIRST-INDEX), 
move  GENDER  of  PERSON  (THIS-NODE)  to  THIS-GENDER. 
set  MALE-INDEX,  FEMALE-INDEX  to  PRIMARY-RELATION, 
if  THIS-GENDER  =  MALE 

string  PRIMARY-MALE-NAME  (MALE-INDEX)  delimited  by  space 
into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 

else 

string  PRIMARY-FEMALE -NAME  (FEMALE -INDEX)  delimited  by  space 
into  DISPLAY -BUFFER  with  pointer  DISPLAY-POINTER. 

if  RELATION-IS-INLAW 

string  "-in-law"  delimited  by  size 

into  DISPLAY -BUFFER  with  pointer  DISPLAY-POINTER. 
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if  (PRIMARY -RELATION  =  COUSIN)  and  (THIS-GENERATION-GAP  >  0) 
if  THIS-GENERATION-GAP  >  1 

move  THIS-GENERATION-GAP  to  TWO-DIGIT-FIELD 
string  "  ",  TWO-DIGIT-FIELD,   "  times  removed" 
delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 

else 

string  "  once  removed"  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER. 

string  "  of"  delimited  by  size 

into  DISPLAY -BUFFER  with  pointer  DISPLAY-POINTER, 
display  DISPLAY-BUFFER. 

GENERATE-GENERATION-QUALIFIER. 

if  THIS-GENERATION-GAP  not  <  3 

string  "great"  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 
if  THIS-GENERATION-GAP  >  3 

subtract  2  from  THIS-GENERATION-GAP  giving  TWO-DIGIT-FIELD 
string  "*",  TWO-DIGIT-FIELD,  "-"  delimited  by  size 
into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER 

else 

string  "-"  delimited  by  size 

into  DISPLAY-BUFFER  with  pointer  DISPLAY-POINTER, 
if  THIS-GENERATION-GAP  not  <  2 

string  "grand-"  delimited  by  size 

into  DISPLAY -BUFFER  with  pointer  DISPLAY-POINTER. 


« 
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*  Compilation  unit  number  3  — - — 

identification  division, 
program-id.  COMGENES. 

*  COMGENES  assumes  that  each  ancestor  contributes 

*  half  of  the  genetic  material  to  a  PERSON.     It  finds  common 

*  ancestors  between  two  PERSONS  and  computes  the  expected 

*  value  of  the  PROPORTION  of  common  material. 


environment  division. 

configuration  section, 
source-computer.  VAX-11. 
object-computer.  VAX-11. 


data  division. 

working- St or age  section. 


01  RELATION-TYPE. 


05 

PARENT 

pic 

9 

value 

1. 

05 

CHILD 

pic 

9 

value 

2. 

05 

SPOUSE 

pic 

9 

value 

3. 

05 

SIBLING 

pic 

9 

value 

4. 

05 

UNCLE 

pic 

9 

value 

5. 

05 

NEPHEW 

pic 

9 

value 

6. 

05 

COUSIN 

pic 

9 

value 

7. 

05 

NULL -RELATION 

pic 

9 

value 

8. 

AUXILIARY-VARIABLES. 
05  COMMON-PROPORTION 
05    MATCH- IDENTIFIER 
05  TEN-DIGIT-FIELD 


pic  9V9999999999. 
pic  999. 

pic  9.999999999. 


01     STACKED -VARIABLES. 
***    used  to  simulate  recursion 
05     STACK-ENTRY      occurs  50 
10  PROPORTION 
10  THIS-CONTRIBUTION 
10  ALREADY-COUNTED 
10  PERSON-INDEX 
10  NEXT-NEIGHBOR 


times  indexed  by  STACK-INDEX, 
pic  9V9999999999. 
pic  9V9999999999. 
pic  9V9999999999. 
usage  index, 
pic  999. 


» 
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linkage  section. 

77    PARM-INDEXl  pic  999. 

77    PARM-INDEX2  pic  999. 

01  PERSON-TABLE. 

05     NUMBER-OF -PERSONS  usage  index. 

05    PERSON  occurs  300  times  indexed  by 
INDEXl,   INDEX2,  THIS -NODE. 
***     static  information  -  filled  from  PEOPLE  file: 
10    NAME  pic  X(20). 

10     IDENTIFIER  pic  999. 

10    GENDER  pic  X. 

***        IDENTIFIERS  of  immediate  relatives  -  father,  mother,  spouse 
10     IMMEDIATE -RELATIONS. 

15    RELATIVE -IDENTIFIER    occurs  3  times  indexed  by  RELATIONSHIP 

pic  999. 

***    pointers  to  immediate  neighbors  in  graph 
10    NEIGHBOR-COUNT  pic  99. 

10    NEIGHBOR-RECORD  occurs  20  times  indexed  by  THIS-NEIGHBOR. 
15     NEIGHBOR-INDEX        usage  index. 
15     NEIGHBOR -EDGE  pic  9. 

***    data  used  when  traversing  graph  to  resolve  user  request: 

10    DI STANCE -FROM-SOURCE     pic  99999V9. 

10     PATH-PREDECESSOR  usage  index. 

10    EDGE-TO-PREDECESSOR      pic  9. 

10    REACHED-STATUS  pic  9. 

***    data  used  to  compute  common  genetic  material 

10    DESCENDANT -IDENTIFIER  pic  999. 

10    DESCENDANT-GENES  pic  9V99999999. 
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procedure  division  using 

PARM-INDEXl,   PARM-INDEX2,  PERSON-TABLE. 

MAIN-LINE. 

set  INDEXl  to  PARM-INDEXl. 

set  INDEX2  to  PARM-INDEX2. 
***    First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 
***     because  there  might  be  two  paths  to  an  ancestor. 

set  STACK-INDEX  to  1. 

set  PERSON-INDEX  (STACK-INDEX)  to  INDEXl. 
move  zero  to  NEXT-NEIGHBOR  (STACK-INDEX), 
perform  ZERO-PROPORTION  until  STACK-INDEX  <  1. 

***    now  mark  with  shared  PROPORTION 

move  IDENTIFIER  of  PERSON  (INDEXl)  to  MATCH-IDENTIFIER, 
set  STACK-INDEX  to  1. 

set  PERSON-INDEX  (STACK-INDEX)  to  INDEXl. 

move  zero  to  NEXT-NEIGHBOR  (STACK-INDEX). 

move  1.0    to  PROPORTION  (STACK-INDEX). 

perform  MARK-PROPORTION  until  STACK-INDEX  <  1. 
***     traverse  ancestor  tree  for  INDEX2,  summing  overlap 
***    with  marked  tree  of  INDEXl 

move  zero  to  COMMON-PROPORTION 

set  STACK-INDEX  to  1. 

set  PERSON-INDEX  (STACK-INDEX)  to  INDEX2. 

move  IDENTIFIER  of  PERSON  (INDEXl)   to  MATCH-IDENTIFIER. 

move  zero  to  NEXT -NEIGHBOR  (STACK-INDEX). 

move  1.0    to  PROPORTION  (STACK-INDEX). 

move  zero  to  ALREADY -COUNTED  (STACK-INDEX). 

perform  CHECK-COMMON-PROPORTION  until  STACK-INDEX  <  1. 

move  COMMON-PROPORTION  to  TEN-DIGIT-FIELD. 

display  "  Proportion  of  common  genetic  material  =  ",  TEN-DIGIT-FIELD. 
END-OF-COMGENES. 
exit  program. 


ZERO-PROPORTION. 
***    ZERO -PROPORTION  recursively  seeks  out  all  ancestors  and 
***     zeros  them  out . 

set  THIS-NODE  to  PERSON-INDEX  (STACK-INDEX), 
if  NEXT-NEIGHBOR  (STACK-INDEX)  =  zero 

move  zero  to  DESCENDANT-GENES  of  PERSON  (THIS-NODE) 
move  1        to  NEXT-NEIGHBOR  (STACK-INDEX), 
perform  NULL 

varying  THIS-NEIGHBOR  from  NEXT -NEIGHBOR  (STACK-INDEX)  by  1 
until  THIS-NEIGHBOR  >  NEIGHBOR -COUNT  (THIS-NODE) 

or  NEIGHBOR-EDGE   (THIS-NODE,  THIS-NEIGHBOR)  =  PARENT, 
if  THIS-NEIGHBOR  >  NEIGHBOR -COUNT  (THIS-NODE) 
***     then  no  more  ancestors 

set  STACK-INDEX  down  by  1 
else 

***  set  up  for  next  ancestor 

set  NEXT -NEIGHBOR  (STACK-INDEX)  to  THIS-NEIGHBOR 

add  1  to  NEXT -NEIGHBOR  (STACK-INDEX) 

set  STACK-INDEX  up  by  1 

set  PERSON-INDEX  (STACK-INDEX) 

to  NEIGHBOR-INDEX  (THIS-NODE,  THIS-NEIGHBOR) 
move  zero  to  NEXT -NEIGHBOR  (STACK-INDEX). 


MARK-PROPORTION. 
***    MARK-PROPORTION  recursively  seeks  out  all  ancestors  and 
***    marks  them  with  the  sender's  PROPORTION  of  shared 
***    genetic  material.     This  PROPORTION  is  diluted  by  one-half 
***    for  each  generation. 

set  THIS-NODE  to  PERSON-INDEX  (STACK-INDEX), 
if  NEXT-NEIGHBOR  (STACK-INDEX)  =  zero 
move  MATCH-IDENTIFIER 

to  DESCENDANT-IDENTIFIER  of  PERSON  (THIS-NODE) 
add  PROPORTION  (STACK-INDEX) 

to  DESCENDANT -GENES  of  PERSON  (THIS-NODE) 

move  1  to  NEXT -NEIGHBOR  (STACK-INDEX), 
perform  NULL 

varying  THIS-NEIGHBOR  from  NEXT -NEIGHBOR  (STACK-INDEX)  by 
until  THIS-NEIGHBOR  >  NEIGHBOR-COUNT  (THIS-NODE) 

or  NEIGHBOR-EDGE   (THIS-NODE,   THIS-NEIGHBOR)  =  PARENT, 
if  THIS-NEIGHBOR  >  NEIGHBOR -COUNT  (THIS-NODE) 
***    then  no  more  ancestors 

set  STACK-INDEX  down  by  1 
else 

***  set  up  for  next  ancestor 

set  NEXT -NEIGHBOR  (STACK-INDEX)  to  THIS-NEIGHBOR 

add  1  to  NEXT -NEIGHBOR  (STACK-INDEX) 

set  STACK-INDEX  up  by  1 

set  PERSON-INDEX  (STACK-INDEX) 

to  NEIGHBOR-INDEX  (THIS-NODE,  THIS-NEIGHBOR) 
move  zero  to  NEXT -NEIGHBOR  (STACK-INDEX) 
divide  PROPORTION  (STACK-INDEX  -  1)  by  2  giving 
PROPORTION  (STACK-INDEX) . 
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CHECK-COMMON-PROPORTION . 
***    CHECK-COMMON-PROPORTION  searches  all  the  ancestors  of 
***    CHECK-INDEX  to  see  if  any  have  been  marked,  and  if  so 
***    adds  the  appropriate  amount  to  COMMON-PROPORTION. 

set  THIS-NODE  to  PERSON-INDEX  (STACK-INDEX), 
if  NEXT -NEIGHBOR  (STACK-INDEX)  =  zero 
move  1  to  NEXT -NEIGHBOR  (STACK-INDEX) 

if  DESCENDANT -IDENTIFIER  of  PERSON  (THIS-NODE)  =  MATCH-IDENTIFIER 
***  Increment  COMMON-PROPORTION  by  the  contribution  of 

***  this  common  ancestor,  but  discount  for  the  contribution 

***  of  less  remote  ancestors  already  counted. 

multiply  DESCENDANT-GENES  of  PERSON  (THIS-NODE) 
by  PROPORTION  (STACK-INDEX) 
giving  THIS-CONTRIBUTION  (STACK-INDEX) 
compute  COMMON-PROPORTION  =  COMMON-PROPORTION 
+  THIS-CONTRIBUTION  (STACK-INDEX) 
-  ALREADY -COUNTED  (STACK-INDEX) 

else 

move  zero  to  THIS-CONTRIBUTION  (STACK-INDEX), 
perform  NULL 

varying  THIS-NEIGHBOR  from  NEXT -NEIGHBOR  (STACK-INDEX)  by  1 
until  THIS-NEIGHBOR  >  NEIGHBOR-COUNT  (THIS-NODE) 

or  NEIGHBOR-EDGE   (THIS-NODE,  THIS-NEIGHBOR)  =  PARENT, 
if  THIS-NEIGHBOR  >  NEIGHBOR -COUNT  (THIS-NODE) 
***     then  no  more  ancestors 

set  STACK-INDEX  down  by  1 
else 

***  set  up  for  next  ancestor 

set  NEXT -NEIGHBOR  (STACK-INDEX)  to  THIS-NEIGHBOR 

add  1  to  NEXT-NEIGHBOR  (STACK-INDEX) 

set  STACK-INDEX  up  by  1 

set  PERSON-INDEX  (STACK-INDEX) 

to  NEIGHBOR-INDEX  (THIS-NODE,  THIS-NEIGHBOR) 
move  zero  to  NEXT -NEIGHBOR  (STACK-INDEX) 
divide  PROPORTION  (STACK-INDEX  -  1)  by  2  giving 

PROPORTION  (STACK-INDEX) 
divide  THIS-CONTRIBUTION  (STACK-INDEX  -  1)  by  4  giving 
ALREADY -COUNTED  (STACK-INDEX). 


NULL. 

exit . 
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6.0  FORTRAN 

In  keeping  with  the  general  convention  of  the  examples,  language-supplied 
keywords  and  identifiers  are  written  in  lower  case  in  the  program.  To  conform 
strictly  to  the  FORTRAN  standard,  however,  programs  must  use  only  upper-case 
letters . 


program  RELATE 
c    Establish  global  constants 

integer  MAXPRS,  NAMLEN,   IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character    NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

c    Each  PERSON'S  record  in  the  file  identifies  at  most  three 
c    others  directly  related:  father,  mother,  and  spouse 

integer        FATHID,  MOTHID,  SPOUID 

parameter  (FATHID  =  1,  MOTHID  =  2,  SPOUID  =  3) 

character    REQOK*10,  REQSTP*A 

parameter  (REQOK  =  'Request  OK',  REQSTP  =  'stop') 

character    MALE*1,  FEMALE*! 
parameter  (MALE  =  'M',  FEMALE  =  'F') 

integer  PARENT,  CHILD,   SPOUSE,  SIBLNG, 

1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  4, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 

c    These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c    the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 


common  /PERCHR/     NAME,   IDENT,   GENDER,  RELID,  DSC ID 
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c     The  following  data  items  constitute  the  PERSON  array,  which 

c     is  the  central  repository  of  information  about  inter-relationships 

c     static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character* 1  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID      (MAXPRS,  MAXGVN) 

c    pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character*(IDLEN)  DSCID  (MAXPRS) 

real  DSC GEN  (MAXPRS) 

c    NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

c    ***  end  of  declarations  for  common  data  *** 

c    These  variables  are  used  when  establishing  the  PERSON  array 
c     from  the  PEOPLE  file. 

integer  CURRNT,  PRVDEX 

character*(IDLEN)  PREVID,  CURRID 

integer  RELSHP 


c  These  variables  are  used  to  accept  and  resolve  requests  for 
c    RELSHP  information. 

BUFDEX,  SEMLOC 
REQBUF 

PlIDNT,  P2IDNT 
PIFND,  P2FND 
ERRMSG 

PIDEX,  P2DEX 
PRNOUN 


integer 

character*(BUFLEN) 
character* (NAMLEN) 
integer 

character* (MSGLEN) 

integer 

character*? 
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c    ***  execution  of  main  sequence  begins  here  *** 

open  (unit=10,  f  ile='PEOPLE.  DAT' ,  status='old' ,  fortn='fonnatted' ) 

c  This  loop  reads  in  the  PEOPLE  file  and  constructs  the  PERSON 

c  array  from  it  (one  PERSON  =  one  record  =  one  array  entry), 

c  As  records  are  read  in,  links  are  constructed  to  represent  the 

c  PARENT -CHILD  or  SPOUSE  relationship.  The  array  then  implements 

c  a  directed  graph  which  is  used  to  satisfy  subsequent  user 

c  requests.     The  file  is  assumed  to  be  correct  -  no  validation 

c  is  performed  on  it. 

do  110  CURRNT=1,  MAXPRS 
c  copy  direct  information  from  file  to  array 

read  (unit=10,  fmt='(a20,  a3,  al,  3a3)',  end=lll) 

1  NAME(CURRNT) ,   IDENT(CURRNT) ,   GENDER ( C URRNT ) , 

2  ((RELID(CURRNT,ITEMP),   ITEMP=FATHID,  SPOUID)) 
c               Location  of  adjacent  persons  as  yet  undetermined 

NBRCNT  (CURRNT)  =  0 
c  Descendants  as  yet  undetermined 

DSCID     (CURRNT)  =  NULLID 
c  Compare  this  PERSON  against  all  previously  entered  PERSONS 

c  to  search  for  relationships. 

CURRID  =  IDENT  (CURRNT) 
do  120  PRVDEX  =  1,  CURRNT -1 
PRE VI D  =  IDENT  (PRVDEX) 
c  Search  for  father,  mother,  or  spouse  relationship  in 

c  either  direction  between  this  and  previous  PERSON, 

c  Assume  at  most  one  relationship  exists, 

do  130  RELSHP  =  FATHID,  SPOUID 

if  (PREVID  .eq.  RELID  (CURRNT,  RELSHP))  then 
call  LNKREL  (CURRNT,  RELSHP,  PRVDEX) 
goto  131 

else  if  (CURRID  .eq.  RELID  (PRVDEX,  RELSHP))  then 
call  LNKREL  (PRVDEX,  RELSHP,  CURRNT) 
goto  131 

end  if 


130  continue 

131  continue 
120  continue 

110  continue 

111  continue 


NUMPER  =  CURRNT  -  1 

close  (unit=10,  status='keep') 

PERSON  array  is  now  loaded  and  edges  between  immediate  relatives 
(PARENT -CHILD  or  SPOUSE -SPOUSE)  are  established. 
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c         Loop  accepts  requests  and  finds  relationship  (if  any) 
c  between  pairs  of  PERSONS. 

200  continue 

call  PROMPT  (REQBUF) 

if  (REQBUF  .eq.  REQSTP)  goto  201 

call  CHKRQS   (REQBUF,  ERRMSG,   PlIDNT,  P2IDNT) 

c  Syntax  check  of  request  completed.     Now  either  display  error 

c  message  or  search  for  the  two  PERSONS. 

if  (ERRMSG  .eq.  REQOK)  then 
c  Request  syntactically  correct  -  search  for  requested  PERSONS 

call  SEEKPR  (PlIDNT,  P2IDNT,  PIDEX,  P2DEX, 
1  PIFND,  P2FND) 

if  (PIFND  .eq.   1   .and.   P2FND  .eq.   1)  then 
c  Exactly  one  match  for  each  PERSON  -  proceed  to 

c  determine  relationship,   if  any. 

if  (PIDEX  .eq.   P2DEX)  then 

if  (GENDER  (PIDEX)   .eq.  MALE)  then 

PRNOUN  =  'himself 
else 

PRNOUN  =  'herself 
end  if 

write  (unit=*,  fmt=9002)  NAME  (PIDEX),  PRNOUN 
9002  format  (a22,  '  is  identical  to  ',  a7,  '.') 

else 

call  FINDRL  (PIDEX,  P2DEX) 
end  if 
else 

c  either  not  found  or  more  than  one  found 

if  (PIFND  .eq.  0)  then 

write  (unit=*,  fmt='("    First  person  not  found.")') 
else  if  (PIFND  .gt.  1)  then 

write  (unit=*, 

1  fmt='("    Duplicate  names  for  first  person", 

2  -  use  numeric  identifier.")') 
end  if 

if  (P2FND  .eq.  0)  then 

write  (unit=*,  fmt='("  Second  person  not  found.")') 
else  if  (P2FND  .gt.   1)  then 

write  (unit=*, 

1  fmt='("    Duplicate  names  for  second  person", 

2  "  -  use  numeric  identifier.")') 
end  if 

end  if 

c  end  processing  of  syntactically  legal  request 

else 

write     (unit=*,  fmt=9004)  ERRMSG 
9004  format  ('     Incorrect  request  format:  ',  a40) 

end  if 
goto  200 

201  continue 

write  (unit=*,  fmt='("    End  of  relation-finder.")') 
c     End  of  main  line  of  RELATE 
end 
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c     procedures  under  RELATE 

subroutine  LNKREL  (FRMDEX,  RELSHP,  TODEX) 
c  establishes  cross-Indexing  between  Immediately  related  PERSONS, 

integer         FRMDEX,   TODEX,  RELSHP 

c     Each  person's  record  in  the  file  Identifies  at  most  three 
c    others  directly  related:  father,  mother,  and  spouse 

integer        FATHID,  MOTHID,  SPOUID 

parameter  (FATHID  =  1,  MOTHID  =  2,  SPOUID  =  3) 

integer  PARENT,  CHILD,  SPOUSE,  SIBLNG, 

1  UNCLE,   NEPHEW,   COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,   SIBLNG  =  A, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 

if  (RELSHP  .eq.  SPOUID)  then 

call  LNKONE  (FRMDEX,  SPOUSE,  TODEX) 

call  LNKONE   (TODEX,  SPOUSE,  FRMDEX) 
else 

c  RELSHP  is  father  or  mother 

call  LNKONE  (FRMDEX,  PARENT,  TODEX) 

call  LNKONE  (TODEX,  CHILD,  FRMDEX) 
end  if 
end 
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subroutine  LNKONE  (FRMDEX,  THSEDG,  TODEX) 
c         Establishes  the  NBR  pointers  from  one  PERSON  to  another 
integer        FRMDEX,  TODEX,  THSEDG 

integer  MAXPRS,  NAMLEN,   IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character     NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

c    These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c    the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSC GEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,   GENDER,  RELID,  DSCID 

c     The  following  data  items  constitute  the  PERSON  array,  which 

c     is  the  central  repository  of  information  about  inter-relationships. 

c     static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*l  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character*(IDLEN)  RELID      (MAXPRS,  MAXGVN) 

c     pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

c    NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

c    ***  end  of  declarations  for  common  data  *** 


ITEMP  =  NBRCNT  (FRMDEX)  +  1 
NBRCNT  (FRMDEX)  =  ITEMP 

NBRDEX  (FRMDEX,   ITEMP)  =  TODEX 
NBREDG  (FRMDEX,   ITEMP)  =  THSEDG 
end 


subroutine  PROMPT  (REQBUF) 
c  Issues  prompt  for  user-request,  reads  in  request, 

c         blank-fills  buffer,  and  skips  to  next  line  of  input. 

character*(*)  REQBUF 

write     (unit=*,  fmt=9001) 
9001    format  (/,'   ' 

1  Enter  two  person- identifiers  (name  or  number),' 

2  /,'     separated  by  semicolon.  Enter  "stop"  to  stop.') 

c  ***  NOTE  THAT  THIS  IS  NOT  A  STANDARD  WAY  TO  READ  A  LINE  FROM 
c  ***  THE  TERMINAL  (see  section  12.9.5.2.1).     THE  STANDARD 
c  ***  PROVIDES  NO  SUCH  CAPABILITY. 

read  (unit=*,  fmt='(a60)')  REQBUF 
end 

subroutine  CHKRQS  (REQBUF,  REQST,   PlIDNT,  P2IDNT) 
c  Performs  syntactic  check  on  request  in  buffer. 

integer  MAXPRS,  NAMLEN,   IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character    NULL ID* (IDLEN) 
parameter  (NULLID  =  '000') 

character    REQOK*10,  REQSTP*4 

parameter  (REQOK  =  'Request  OK',  REQSTP  =  'stop') 

character  REQBUF* ( BUFLEN ) ,  REQST*(MSGLEN) 

character* (NAMLEN)     PlIDNT,  P2IDNT,  LTRIM 
integer  SEMLOC 

SEMLOC  =  INDEX  (REQBUF,';') 

P2IDNT  =  REQBUF  ( SEMLOC +1   :  BUFLEN) 


set  REQST,  based  on  results  of  scan  of  REQBUF,  and 
fill  in  PlIDNT  and  P2IDNT. 
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if  (SEMLOC   .eq.  0  .or.  INDEX  (P2IDNT,   ';')   .ne.  0)  then 
REQST  =  'must  be  exactly  one  semicolon.' 

else 

if  (SEMLOC   .eq.   1)  then 

PlIDNT  =  '  ' 
else 

PlIDNT  =  REQBUF  (1   :  SEMLOC-1) 
end  if 

if  (PlIDNT  .eq.   '  ')  then 

REQST  =  'null  field  preceding  semicolon.' 
else  if  (P2IDNT  .eq.  '  ')  then 

REQST  =  'null  field  following  semicolon.' 
else 

REQST     =  REQOK 

PlIDNT  =  LTRIM  (PlIDNT) 

P2IDNT  =  LTRIM  (P2IDNT) 
end  if 
end  if 
end 

character* (*)  function  LTRIM  (STRING) 
c  LTRIM  deletes  leading  spaces  and  returns  the  resulting  value. 

character* (*)  STRING 

do  100  ITEMP  =  1,   len( STRING) 

if  (STRING  (ITEMP  :   ITEMP)   .ne.  '  ')  goto  101 

100  continue 

101  continue 

LTRIM  =  STRING  (ITEMP  :  len( STRING)) 
end 

subroutine  SEEKPR     (PlIDNT,   P2IDNT,   PIDEX,  P2DEX, 
1  PIFND,  P2FND) 

c  SEEKPR  scans  through  the  PERSON  array,  looking  for  the  two 

c  requested  PERSONS.     Match  may  be  by  NAME  or  unique  IDENT-number . 

integer  MAXPRS,   NAMLEN,   IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,   IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character     NULLID*( IDLEN) 
parameter  (NULL ID  =  '000') 

character* (NAMLEN)       PlIDNT,  P2IDNT 

integer  PIDEX,  P2DEX,  PIFND,  P2FND 


integer 


CURRNT 
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c    These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c    the  entire  program. 

common  /PEBINUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,   GENDER,   RELID,  DSCID 

c    The  following  data  items  constitute  the  PERSON  array,  which 

c    is  the  central  repository  of  information  about  inter-relationships 

c    static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*l  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character*(IDLEN)  RELID      (MAXPRS,  MAXGVN) 

c    pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT     (MAXPRS ) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD     (MAXPRS ) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

c    NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

c    ***  end  of  declarations  for  common  data  *** 


PIDEX  =  0 
P2DEX  =  0 
PIFND  =  0 
P2FND  =  0 

do  100  CURRNT  =  1,  NUMPER 
c  allow  identification  by  name  or  number, 

if  (PlIDNT  .eq.  IDENT  (CURRNT)  .or. 
1  PlIDNT  .eq.  NAME     (CURRNT))  then 

PIFND  =  PIFND  +  1 
PIDEX  =  CURRNT 
end  if 

if  (P2IDNT  .eq.   IDENT  (CURRNT)  .or. 
1  P2IDNT  .eq.  NAME     (CURRNT))  then 

P2FND  =  P2FND  +  1 
P2DEX  =  CURRNT 
end  if 
100  continue 
end 
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subroutine  FINDRL  (TRGDEX,  SRCDEX) 

c  Finds  shortest  path  (if  any)  between  two  PERSONS  and 

c  determines  their  relationship  based  on  immediate  relations 

c  traversed  in  path.     PERSON  array  simulates  a  directed  graph, 

c  and  algorithm  finds  shortest  path,  based  on  following 

c  weights:  PARENT -CHILD  edge  =  1.0 
c  SPOUSE-SPOUSE  edge  =  1.8 

integer        TRGDEX,  SRCDEX 


integer  MAXPRS,  NAMLEN,   IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,   IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character    NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

c    A  node  in  the  graph  (=  PERSON)  has  either  already  been  reached, 
c     is  immediately  adjacent  to  those  reached,  or  farther  away. 

integer        REACHD,  NEARBY,  NOSEEN 

parameter  (REACHD  =  1,  NEARBY  =  2,  NOSEEN  =  3) 

c     These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c     the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,  GENDER,  RELID,  DSCID 

c     The  following  data  items  constitute  the  PERSON  array,  which 

c    is  the  central  repository  of  information  about  inter-relationships. 

c     static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*l  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID      (MAXPRS,  MAXGVN) 

c    pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX    (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character*(IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

c    NUMPER  keeps  track  of  the  actual  number  of  persons 

integer  NUMPER 
c    ***  end  of  declarations  for  common  data  *** 
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integer  PERDEX,  THSNOD,  ADJNOD, 

1  BSTDEX,   LASTNR,   NEARND  (MAXPRS) 

integer  THSEDG,  THSNBR 

integer  RELSHP 

real  HINDIS 

integer  SRCHNG,  SUCCES,  FAILED 

parameter  (SRCHNG  =  1,  SUCCES  =  2,  FAILED  =  3) 

integer  SRCHST 


c    begin  execution  of  FINDRL 

c  initialize  PERSON-array  for  processing  - 

c         mark  all  nodes  as  not  seen 

do  100  PERDEX  =  1,  NUMPER 
RCHST  (PERDEX)  =  NOSEEN 
100  continue 

THSNOD  =  SRCDEX 
c         mark  source  node  as  reached 

RCHST     (THSNOD)  =  REACHD 

DSTSRC  (THSNOD)  =0.0 
c  no  NEARBY  nodes  exist  yet 

LASTNR  =  0 

if  (THSNOD  .eq.  TRGDEX)  then 

SRCHST  =  SUCCES 
else 

SRCHST  =  SRCHNG 
end  if 
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c  Loop  keeps  processing  closest-to-source ,  unreached  node 

c         until  target  reached,  or  no  more  connected  nodes. 

200  continue 

if  (SRCHST  .ne.  SRCHNG)  goto  201 
c  Process  all  nodes  adjacent  to  THSNOD 

do  210  THSNBR  =  1,  NBRCNT  (THSNOD) 

call  PROCAD  (THSNOD,  NBRDEX     (THSNOD,  THSNBR), 
1  NBREDG  (THSNOD,  THSNBR),  NEARND,  LASTNR) 

210  continue 

c  All  nodes  adjacent  to  THSNOD  are  set.     Now  search  for 

c  shortest-distance  unreached  (but  NEARBY)  node  to  process  next. 

if  (LASTNR  .eq.  0)  then 
SRCHST  =  FAILED 

else 

c  determine  next  node  to  process 

HINDIS  =  l.OE+18 
do  220  PERDEX  =  1,  LASTNR 

if  (DSTSRC  (NEARND  (PERDEX))   .It.  HINDIS)  then 
BSTDEX  =  PERDEX 

HINDIS  =  DSTSRC  (NEARND  (PERDEX)) 
end  if 
220  continue 
c  establish  new  THSNOD 

THSNOD  =  NEARND  (BSTDEX) 
c  change  THSNOD  from  being  NEARBY  to  reached 

RCHST  (THSNOD)  =  REACHD 
c  remove  THSNOD  from  NEARBY  list 

NEARND  (BSTDEX)  =  NEARND  (LASTNR) 

LASTNR  =  LASTNR  -  1 

if  (THSNOD  .eq.  TRGDEX)  SRCHST  =  SUCCES 
end  if 
goto  200 

201  continue 

c  Shortest  path  between  PERSONS  now  established.     Next  task  is 

c  to  translate  path  to  English  description  of  relationship. 

if  (SRCHST  .eq.  FAILED)  then 

write  (unit=*,  fmt=9001)  NAHE  (TRGDEX),  NAME  (SRCDEX) 
9001  format  (a22,  '  is  not  related  to  a20) 

else 

c  success  -  parse  path  to  find  and  display  relationship 

call  RESOLV  (SRCDEX,  TRGDEX) 
c  compute  proportion  of  common  genetic  material 

call  CHPTGN  (SRCDEX,  TRGDEX) 
end  if 
end 
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c    procedures  under  FINDRL 

subroutine  PROCAD  (BASNOD,  NXTNOD,  NBEDGE,   NEARND,  LASTNR) 

c  NXTNOD  is  adjacent  to  last-reached  node  (=  BASNOD). 

c  If  NXTNOD  already  reached,  do  nothing, 

c  If  previously  seen,  check  whether  path  thru  BASNOD  is 

c  shorter  than  current  path  to  NXTNOD,  and  if  so  re-link 

c  next  to  base . 

c  If  not  previously  seen,  link  next  to  base  node. 

integer  NXTNOD,   BASNOD,  NEARND(*),  LASTNR 
integer  NBEDGE 

integer  MAXPRS,  NAMLEN,   IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,   IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character     NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

c    A  node  in  the  graph  (—  PERSON)  has  either  already  been  reached, 
c    is  immediately  adjacent  to  those  reached,  or  farther  away. 

integer        REACHD,  NEARBY,  NOSEEN 

parameter  (REACHD  =  1,  NEARBY  =  2,  NOSEEN  =  3) 

c     These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c     the  entire  program. 

common  /PERNUM/  NBRCNT,   NBRDEX,   NBREDG,   DSTSRC,  PATHPR, 

1  EDGPRD,   RCHST,   DSC GEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,  GENDER,  RELID,  DSCID 

c     The  following  data  items  constitute  the  PERSON  array,  which 

c     is  the  central  repository  of  information  about  inter-relationships, 


static  information  -  filled  from  PEOPLE  file 
character* (NAMLEN)  NAME  (MAXPRS) 

character*(IDLEN)  IDENT  (MAXPRS) 

character*l  GENDER  (MAXPRS) 

IDENTs  of  immediate  relatives  -  father,  mother,  spouse 
character* (IDLEN)  RELID       (MAXPRS,  MAXGVN) 

pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

data  used  when  traversing  graph  to  resolve  user  request 
real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

data  used  to  compute  common  genetic  material 
character*(IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 
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c    NUMPER  keeps  track  of  the  actual  number  of  persons 
Integer  NUMPER 

c    ***  end  of  declarations  for  common  data  *** 

real  WGHTEG,  DSTBAS 

c  begin  execution  of  PROCAD 

if  (RCHST  (NXTNOD)   .ne.  REACHD)  then 
if  (NBEDGE   .eq.   SPOUSE)  then 

WGHTEG  =  1.8 
else 

WGHTEG  =1.0 
end  if 

DSTBAS  =  WGHTEG  +  DSTSRC  (BASNOD) 
7    if  (RCHST  (NXTNOD)   .eq.  NOSEEN)  then 
c  change  status  of  THSNOD  from  not-seen  to  NEARBY 

RCHST  (NXTNOD)  =  NEARBY 
LASTNR  =  LASTNR  +  1 
NEARND  (LASTNR)  =  NXTNOD 
c  link  next  to  base  by  re-setting  its  predecessor  index  to 

c  point  to  base,  note  type  of  edge,  and  re-set  distance 

c  as  it  is  through  base  node. 

DSTSRC  (NXTNOD)  =  DSTBAS 
PATHPR  (NXTNOD)  =  BASNOD 
EDGPRD  (NXTNOD)  =  NBEDGE 
else 

c  RCHST  is  NEARBY 

if  (DSTBAS  .It.  DSTSRC  (NXTNOD))  then 


c  link  next  to  base  by  re-setting  its  predecessor  index 

c  point  to  base,  note  type  of  edge,  and  re-set  distance 

c  as  it  is  through  base  node. 

DSTSRC  (NXTNOD)  =  DSTBAS 

PATHPR  (NXTNOD)  =  BASNOD 


EDGPRD  (NXTNOD)  =  NBEDGE 
end  if 
end  if 
end  if 
end 


subroutine  RESOLV  (SRCDEX,  TRGDEX) 

RESOLV  condenses  the  shortest  path  to  a  series  of 

relationships  for  which  there  are  English  descriptions. 


integer  SRCDEX,  TRGDEX 
Establish  global  constants 


integer        MAXPRS,  NA.MLEN,   IDLEN,  BUFLEN, 
1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  = 
1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character  NULLID*(IDLEN) 
parameter  (NULLID  =  '000') 

character    MALE*1,  FEMALE*1 
parameter  (MALE  =  'M',  FEMALE  =  'F') 


integer  PARENT,  CHILD,  SPOUSE,  SIBLNG, 

1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  A, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 

sibling  proximity  can  have  three  values 

integer        STEP,  HALF,  FULL 

parameter  (STEP  =  1,  HALF  =  2,  FULL  =  3) 

These  common  blocks  hold  the  PERSON  array,  which  is  global  t 
the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,  DSCGEN,  NUMPER 


common  /PERCHR/    NAME,   IDENT,  GENDER,  RELID,  DSCID 
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c     The  following  data  items  constitute  the  PERSON  array,  which 

c     is  the  central  repository  of  information  about  inter-relationships 

c    static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character*(IDLEN)  IDENT  (MAXPRS) 

character*l  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID      (MAXPRS,  MAXGVN) 

c    pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character*(IDLEN)  DSCID  (MAXPRS) 

real  DSC GEN  (MAXPRS) 

c    NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

c     ***  end  of  declarations  for  common  data  *** 


c 

these  variables 

are  used  to  generate  key-person  data 

integer 

GENCNT,  THSCUZ 

integer 

THSPRX 

c 

these  variables 

are  used  to  condense  the  path 

common  /KEYPER/ 

RELNXT,   PERDEX,   GENGAP,   PRXMTY,  CUZRNK 

c 

Key  persons  are 

the  ones  in  the  relationship  path  which 

c 

after  the  path 

is  condensed. 

integer 

RELNXT  (MAXPRS) 

integer 

PERDEX  (MAXPRS) 

integer 

GENGAP  (MAXPRS) 

integer 

PRXMTY  (MAXPRS) 

integer 

CUZRNK  (MAXPRS) 

integer 

KEYREL,  LATREL,   PRIREL,  NXTPRI 

integer 

KEYDEX,  LATDEX,   PRIDE X,  THSNOD 

integer 

GAPl,  GAP2 

logical 


SEEKMR,  FULSIB 
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c  begin  execution  of  RESOLV 

write  (unit=*, 

1  fmt='("    Shortest  path  between  identified  persons:  ")') 

c         Display  path  and  initialize  key  person  arrays  from  path  elements. 
THSNOD     =  TRGDEX 
do  100  KEYDEX  =  1,  MAXPRS 

if  (THSNOD  .eq.  SRCDEX)  goto  101 

PERDEX  (KEYDEX)  =  THSNOD 

PRXMTY  (KEYDEX)  =  FULL 

RELNXT  (KEYDEX)  =  EDGPRD  (THSNOD) 

if  (EDGPRD  (THSNOD)   .eq.  SPOUSE)  then 

write  (unit=*,   fmt='(a22,   "  is  spouse  of")')  NAME  (THSNOD) 
GENGAP  (KEYDEX)  =  0 
else 

GENGAP  (KEYDEX)  =  1 

if  (EDGPRD  (THSNOD)  .eq.  PARENT)  then 

write  (unit=*,  fmt='(a22,  "  is  parent  of")') 
1  NAME  (THSNOD) 

else 

write  (unit=*,  fmt='(a22,  "  is  child  of")') 
1  NAME  (THSNOD) 

end  if 
end  if 

THSNOD  =  PATHPR  (THSNOD) 

100  continue 

101  continue 

write  (unit=*,  fmt='(a22)')  NAME  (THSNOD) 
PERDEX  (KEYDEX)  =  THSNOD 

RELNXT  (KEYDEX)  =  NULLRL 

RELNXT  (KEYDEX  +  1)  =  NULLRL 
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c  resolve  CHILD-PARENT  and  CHILD-SPOUSE-PARENT  relations 

c  to  SIBLNG  relations. 

do  200  KEYDEX  =  1,  MAXPRS 

If  (RELNXT  (KEYDEX)   .eq.  NULLRL)  goto  201 
if  (RELNXT  (KEYDEX)   .eq.  CHILD)  then 
LATREL  =  RELNXT  (KEYDEX  +  1) 
if  (LATREL  .eq.   PARENT)  then 
c  found  either  full  or  half  SIBLNGs 

if  (FULSIB  (PERDEX  (KEYDEX),  PERDEX  (KEYDEX  +  2)))  then 

PRXMTY  (KEYDEX)  =  FULL 
else 

PRXMTY  (KEYDEX)  =  HALF 
end  if 

GENGAP  (KEYDEX)  =  0 
RELNXT  (KEYDEX)  =  SIBLNG 
call  CONDNS  (KEYDEX,  1) 
else  if  (LATREL  .eq.  SPOUSE  .and. 
1  RELNXT  (KEYDEX  +  2)   .eq.  PARENT)  then 

c  found  step-SIBLNGs 

GENGAP  (KEYDEX)  =  0 
PRXMTY  (KEYDEX)  =  STEP 
RELNXT  (KEYDEX)  =  SIBLNG 
call  CONDNS  (KEYDEX,  2) 
end  if 
end  if 

200  continue 

201  continue 


c  resolve  CHILD-CHILD-. . .  and  PARENT -PARENT-. . .  relations  to 

c         direct  descendant  or  ancestor  relations, 
do  300  KEYDEX  =  1,  MAXPRS 

if  (RELNXT  (KEYDEX)   .eq.  NULLRL)  goto  301 
if  (RELNXT  (KEYDEX)   .eq.  CHILD  .or. 
1  RELNXT  (KEYDEX)   .eq.   PARENT)  then 

do  310  LATDEX  =  KEYDEX  +  1,  MAXPRS 

if  (RELNXT  (LATDEX)   .ne.  RELNXT  (KEYDEX))  goto  311 

310  continue 

311  continue 

GENCNT  =  LATDEX  -  KEYDEX 
if  (GENCNT  .gt.  1)  then 
c  compress  generations 

GENGAP  (KEYDEX)  =  GENCNT 
call  CONDNS  (KEYDEX,   GENCNT  -  1) 
end  if 
end  if 

300  continue 

301  cont  inue 
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c  resolve  CHILD-SIBLNG-PARENT  to  COUSIN, 

c  CHILD-SIBLNG  to  NEPHEW, 

C  SIBLNG-PARENT  to  UNCLE, 

do  400  KEYDEX  =  1,  MAXPRS 

if  (RELNXT  (KEYDEX)   .eq.  NULLRL)  goto  AOl 
LATREL  =  RELNXT  (KEYDEX  +  1) 

if  (RELNXT  (KEYDEX)   .eq.  CHILD  .and.  LATREL  .eq.  SIBLNG)  then 
c  found  COUSIN  or  NEPHEW 

PRXMTY  (KEYDEX)  =  PRXMTY  (KEYDEX  +  1) 
if  (RELNXT  (KEYDEX  +  2)   .eq.   PARENT)  then 
c  found  COUSIN 

GAPl  =  GENGAP  (KEYDEX) 
GAP2  =  GENGAP  (KEYDEX  +  2) 
GENGAP  (KEYDEX)  =  abs  (GAPl  -  GAP2) 
CUZRNK  (KEYDEX)  =  mln  (GAPl,  GAP2) 
RELNXT  (KEYDEX)  =  COUSIN 
call  CONDNS  (KEYDEX,  2) 
else 

c  found  NEPHEW 

RELNXT  (KEYDEX)  =  NEPHEW 
call  CONDNS  (KEYDEX,  1) 
end  if 
else 

if  (RELNXT  (KEYDEX)   .eq.  SIBLNG  .and. 
1  LATREL  .eq.   PARENT)  then 

c  found  UNCLE 

GENGAP  (KEYDEX)  =  GENGAP  (KEYDEX  +  1) 
RELNXT  (KEYDEX)  =  UNCLE 
call  CONDNS  (KEYDEX,  1) 
end  if 
end  if 
AGO  continue 
401  continue 


Page  118 


c  Loop  below  will  pick  out  valid  adjacent  strings  of  elements 

c  to  be  displayed.     KEYDEX  points  to  first  element, 

c  LATDEX  to  last  element,  and  PRIDEX  to  the 

c  element  which  determines  the  primary  English  word  to  be  used, 

c  Associativity  of  adjacent  elements  in  condensed  table 

c  is  based  on  English  usage. 


KEYDEX  =  1 

write  (unit=*,  fmt='("    Condensed  path:")') 
500  continue 

if  (RELNXT  (KEYDEX)   .eq.  NULLRL)  goto  501 
KEYREL  =  RELNXT  (KEYDEX) 
LATDEX  =  KEYDEX 
PRIDEX  =  KEYDEX 

if  (RELNXT  (KEYDEX  +  1)   .ne.  NULLRL)  then 
c    .  seek  multi-element  combination 

SEEKMR  =  .true, 
if  (KEYREL  .eq.  SPOUSE)  then 
LATDEX  =  LATDEX  +  1 
PRIDEX  =  LATDEX 

c  Nothing  can  follow  SPOUSE-SIBLNG  or  SPOUSE-COUSIN 

SEEKMR  =  .not.   (RELNXT  (LATDEX)   .eq.   SIBLNG  .or. 
1  RELNXT  (LATDEX)   .eq.  COUSIN) 

end  if 


c  PRIDEX  is  now  correctly  set.     Next  if-statement 

c  determines  if  a  following  SPOUSE  relation  should  be 

c  appended  to  this  combination  or  left  for  the  next 

c  combination. 

if  (SEEKMR  .and.  RELNXT  (PRIDEX  +  1)   .eq.  SPOUSE)  then 
c  Only  a  SPOUSE  can  follow  a  Primary. 

C  Check  primary  preceding  and  following  SPOUSE. 

PRIREL  =  RELNXT  (PRIDEX) 

NXTPRI  =  RELNXT  (PRIDEX  +  2) 

if  ((NXTPRI  .eq.  NEPHEW  .or. 

1  NXTPRI  .eq.  COUSIN  .or. 

2  NXTPRI   .eq.  NULLRL) 

3  .or.  (PRIREL  .eq.  NEPHEW) 

4  .or.   ((PRIREL  .eq.   SIBLNG  .or.   PRIREL  .eq.  PARENT) 

5  .and.  NXTPRI  .ne.  UNCLE  ))  then 

c  append  following  SPOUSE  with  this  combination. 

LATDEX  =  LATDEX  +  1 
end  if 
end  if 


end  if 

c  end  multi-element  combination 

call  SHOWRE  (KEYDEX,  LATDEX,  PRIDEX) 
KEYDEX  =  LATDEX  +  1 
goto  500 
501  continue 

write  (unit=*,  fmt='(a22)')  NAME  (PERDEX  (KEYDEX)) 
end 

c  end  of  RESOLV 


logical  function  FULSIB  (INDEXl,  INDEX2) 

Determines  whether  two  PERSONS  are  full  siblings,  i.e., 

have  the  same  two  parents . 


integer 


INDEXl,  INDEX2 


integer  MAXPRS,  NAMLEN,  IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN 

character  NULL1D*( IDLEN) 

parameter  (NULLID  =  '000') 

integer  FATHID,  MOTHID,  SPOUID 

parameter  (FATHID  =  1,  MOTHID  =  2,   SPOUID  =  3) 


3,  BUFLEN  =  60, 
3) 


These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,   GENDER,  RELID,  DSCID 

The  following  data  items  constitute  the  PERSON  array,  which 

is  the  central  repository  of  information  about  inter-relationships 

static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*!  GENDER  (MAXPRS) 

IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID       (MAXPRS,  MAXGVN) 

pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  -  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

NUMPER  keeps  track  of  the  actual  number  of  persons 

integer     ^  NUMPER 

***  end  of  declarations  for  common  data  *** 


FULSIB  = 

1  RELID  (INDEXl,  FATHID)  .ne.  NULLID  .and. 

2  RELID  (INDEXl,  MOTHID)  .ne.  NULLID  .and. 

3  RELID  (INDEXl,  FATHID)  .eq.  RELID  (INDEX2,  FATHID)  .and. 

4  RELID  (INDEXl,  MOTHID)  .eq.  RELID  (INDEX2,  MOTHID) 
end 
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subroutine  CONDNS  (ATDEX,  GAPSIZ) 
c         CONDNS  condenses  superfluous  entries  from  the 
c         key  person  arrays,  starting  at  ATDEX. 

integer        MAXPRS,  NAMLEN,  IDLEN,  BUFLEN, 
1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  =  60, 
1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character     NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

integer  PARENT,  CHILD,  SPOUSE,  SIBLNG, 

1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  4, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 

common  /KEYPER/  RELNXT,   PERDEX,   GENGAP,   PRXMTY,  CUZRNK 

c  Key  persons  are  the  ones  in  the  relationship  path  which  remain 
c  after  the  path  is  condensed. 


integer  RELNXT  (MAXPRS) 

integer  PERDEX  (MAXPRS) 

integer  GENGAP  (MAXPRS) 

integer  PRXMTY  (MAXPRS) 

integer  CUZRNK  (MAXPRS) 

integer  ATDEX,  GAPSIZ,  SENDEX,  RCVDEX 


RCVDEX  =  ATDEX 
100  continue 

RCVDEX  =  RCVDEX  +  1 

SENDEX  =  RCVDEX  +  GAPSIZ 

RELNXT  (RCVDEX)  =  RELNXT  (SENDEX) 

PERDEX  (RCVDEX)  =  PERDEX  (SENDEX) 

GENGAP  (RCVDEX)  =  GENGAP  (SENDEX) 

PRXMTY  (RCVDEX)  =  PRXMTY  (SENDEX) 

CUZRNK  (RCVDEX)  =  CUZRNK  (SENDEX) 

if  (RELNXT  (SENDEX)   .ne.  NULLRL)  goto  100 

end 


c    procedures  under  RESOLV 


subroutine  SHOWRE  (FSTDEX,  LSTDEX,  PRIDEX) 
c  SHOWRE  takes  1,   2,  or  3  adjacent  elements  In  the 

c  condensed  table  and  generates  the  English  description  of 

c  the  relation  between  the  first  and  last  +  1  elements. 


c    Establish  global  constants 


integer  MAXPRS,  NAMLEN,  IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  =  60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character     NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

character    MALE*1,  FEMALE*! 
parameter  (MALE  =  'M' ,  FEMALE  =  'F') 

integer  PARENT,  CHILD,  SPOUSE,  SIBLNG, 

1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  4, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 

c    sibling  proximity  can  have  three  values 

integer        STEP,  HALF,  FULL 

parameter  (STEP  =  1,  HALF  =  2,  FULL  =  3) 

c     These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c    the  entire  program. 

common  /PERNUM/  NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 

1  EDGPRD,  RCHST,  DSC GEN,  NUMPER 


common  /PERCHR/     NAME,   IDENT,  GENDER,   RELID,  DSCID 
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c    The  following  data  items  constitute  the  PERSON  array,  which 

c    is  the  central  repository  of  information  about  inter-relationships 

c    static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*!  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID      (MAXPRS,  MAXGVN) 

c    pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSCID  (MAXPRS) 

real  DSC GEN  (MAXPRS) 

c    NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

common  /KEYPER/  RELNXT,   PERDEX,   GENGAP,   PRXMTY,  CUZRNK 

c         Key  persons  are  the  ones  in  the  relationship  path  which  remain 
c         after  the  path  is  condensed. 


integer 
integer 
integer 
integer 
integer 


RELNXT  (MAXPRS) 
PERDEX  (MAXPRS) 
GENGAP  (MAXPRS) 
PRXMTY  (MAXPRS) 
CUZRNK  (MAXPRS) 


c    ***  end  of  declarations  for  common  data  *** 


logical 

integer 

character 

integer 

character 

integer 

integer 

character*75 

integer 


INLAW 

THSPRX,  THSGAP,  THSCUZ 

TW0DIG*2 

SUFPTR 

SUFCHR*12 

FSTDEX,   LSTDEX,  PRIDEX 
FSTREL,  LSTREL,  PRIREL 
OUTBUF 
OUTPTR 


begin  execution  of  SHOWRE 


FSTREL  =  RELNXT  (FSTDEX) 
LSTREL  =  RELNXT  (LSTDEX) 
PRIREL  =  RELNXT  (PRIDEX) 


set  THSPRX 

if  ((PRIREL  .eq.   PARENT  .and.  FSTREL  .eq.   SPOUSE)  .or. 
1         (PRIREL  .eq.  CHILD     .and.  LSTREL  .eq.  SPOUSE))  then 
THSPRX  =  STEP 
else 

if  (PRIREL  .eq.  SIBLNG  .or.  PRIREL  .eq.  UNCLE  .or. 
1  PRIREL  .eq.  NEPHEW  .or.   PRIREL  .eq.  COUSIN)  then 

THSPRX  =  PRXMTY  (PRIDEX) 
else 

THSPRX  =  FULL 
end  if 
end  if 

set  THSGAP 

if  (PRIREL  .eq.  PARENT  .or.  PRIREL  .eq.  CHILD  .or. 

1  PRIREL  .eq.  UNCLE     .or.   PRIREL  .eq.  NEPHEW  .or. 

2  PRIREL  .eq.  COUSIN)  then 
THSGAP  =  GENGAP  (PRIDEX) 

else 

THSGAP  =  0 
end  if 


set  INLAW 

if  (FSTREL  .eq.  SPOUSE  .and. 

1  (PRIREL  .eq.   SIBLNG  .or.   PRIREL  .eq.  CHILD  .or. 

2  PRIREL  .eq.  NEPHEW  .or.  PRIREL  .eq.  COUSIN))  then 
INLAW  =  .true. 

else 

if  (LSTREL  .eq.   SPOUSE  .and. 

1  (PRIREL  .eq.   SIBLNG  .or.   PRIREL  .eq.   PARENT  .or. 

2  PRIREL  .eq.  UNCLE     .or.  PRIREL  .eq.  COUSIN))  then 
INLAW  =  .true. 

else 

INLAW  =  .false, 
end  if 
end  if 


set  THSCUZ 

if  (PRIREL  .eq.  COUSIN)  then 
THSCUZ  =  CUZRNK  (PRIDEX) 

else 

THSCUZ  =  0 

end  if 
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c         parameters  are  set  -  now  generate  display. 

OUTBUF  =  NAME  (PERDEX  (FSTDEX))  //  '  is  ' 
OUTPTR  =  NAMLEN  +  5 

if  (PRIREL  .eq.  PARENT  .or.  PRIREL  .eq.  CHILD  .or. 
1        PRIREL  .eq.  UNCLE  .or.     PRIREL  .eq.  NEPHEW)  then 
c  display  generation-qualifier 

if  (THSGAP  .ge.  3)  then 

call  APPEND  (OUTBUF,  OUTPTR,  'great') 
if  (THSGAP  .gt.  3)  then 

write  (unit=TWODIG,  fmt='(i2)')  THSGAP  -  2 
call  APPEND  (OUTBUF,  OUTPTR,  '*'  //  TWODIG) 
end  if 

call  APPEND  (OUTBUF,  OUTPTR,  '-') 
end  if 

if  (THSGAP  .ge.  2)  then 

call  APPEND  (OUTBUF,  OUTPTR,  'grand-') 
end  if 
else 

if  (PRIREL  .eq.  COUSIN  .and.  THSCUZ  .gt.   I)  then 
c  display  cousin-degree 

write  (unit=TWODIG,  fmt='(i2)')  THSCUZ 

call  APPEND  (OUTBUF,  OUTPTR,  TWODIG) 

SUFPTR  =  mod  (THSCUZ,  10) 

if  (SUFPTR  .gt.   3)  SUFPTR  =  0 

SUFPTR  =  3  *  SUFPTR  +  1 

SUFCHR  =  'th  St  nd  rd  ' 

call  APPEND  (OUTBUF,  OUTPTR,   SUFCHR  (SUFPTR  :  SUFPTR  +2)) 
end  if 
end  if 

if  (THSPRX  .eq.  STEP)  then 

call  APPEND  (OUTBUF,  OUTPTR,  'step-') 
else 

if  (THSPRX  .eq.  HALF)  then 

call  APPEND  (OUTBUF,  OUTPTR,  'half-') 
end  if 
end  if 
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if  (GENDER  (PERDEX  (FSTDEX))   .eq.  MALE)  then 

goto  (201,202,203,204,205,206,297,298),  PRIREL 

201  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'father') 
goto  300 

202  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'son') 
goto  300 

203  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'husband') 
goto  300 

204  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'brother') 
goto  300 

205  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'uncle') 
goto  300 

206  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'nephew') 
goto  300 

else 

c  gender  is  FEMALE 

goto  (251,252,253,254,255,256,297,298),  PRIREL 

251  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'mother') 
goto  300 

252  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'daughter') 
goto  300 

253  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'wife') 
goto  300 

254  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'sister') 
goto  300 

255  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'aunt') 
goto  300 

256  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'niece') 
goto  300 

end  if 

297  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'cousin') 
goto  300 

298  continue 

call  APPEND  (OUTBUF,  OUTPTR,  'null') 
goto  300 
300  continue 
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if  (INLAW)  call  APPEND  (OUTBUF,  OUTPTR,  '-in-law') 

if  (PRIREL  .eq.  COUSIN  .and.  THSGAP  .gt.  0)  then 
if  (THSGAP  .gt.   1)  then 

write  (unit=TWODIG,   fmt='(i2)')  THSGAP 

call  APPEND  (OUTBUF,  OUTPTR,   '  '//TWODIG//'  times  removed') 
else 

call  APPEND  (OUTBUF,  OUTPTR,   '  once  removed') 
end  if 
end  if 

call  APPEND  (OUTBUF,  OUTPTR,  'of') 
write  (unit=*,  fmt='(a77)')  OUTBUF 
end 

subroutine  APPEND  (STRING,   PTR,  ADDEND) 
c         APPEND  appends  the  contents  of  ADDEND  to  STRING  in  the  position 
c  indicated  by  PTR,  and  increments  PTR 

character  STRING*(*),  ADDEND*(*) 

integer  PTR,  ADDLEN 

ADDLEN  =  len  (ADDEND) 

STRING  (PTR  :  PTR  +  ADDLEN  -  1)  =  ADDEND 

PTR  =  PTR  +  ADDLEN 

end 

c    procedures  under  FINDRL 

subroutine  CMPTGN  (INDEXl,  INDEX2) 
c         CMPTGN  assumes  that  each  ancestor  contributes 
c         half  of  the  genetic  material  to  a  PERSON.     It  finds  common 
c         ancestors  between  two  PERSONS  and  computes  the  expected 
c         value  of  the  proportion  of  common  material. 

integer        INDEXl,  INDEX2 

integer        MAXPRS,  NAMLEN,  IDLEN,  BUFLEN, 
1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN 
1  MSGLEN  =  AO,  MAXNBR  =  20,  MAXGVN 

character     NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

c    These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
2     the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,   GENDER,  RELID,  DSC ID 


=  3,  BUFLEN  =  60, 
=  3) 
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c     The  following  data  items  constitute  the  PERSON  array,  which 

c     is  the  central  repository  of  information  about  inter-relationships 

c     static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character*(IDLEN)  IDENT  (MAXPRS) 

character*!  GENDER  (MAXPRS) 

c     IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character*(IDLEN)  RELID       (MAXPRS,  MAXGVN) 

c    pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

c    data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

c    data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

c     NUMPER  keeps  track,  of  the  actual  number  of  persons 
integer  NUMPER 

c     STACK  is  common  to  the  routines  which  calculate  genetic  overlap, 
c     It  is  used  to  implement  recursive  traversal  of  the  ancestor  trees. 

integer  STKSIZ 
parameter  (STKSIZ  =50) 

common  /STACK/  PROPTN,  CONTRB,  COUNTD,   PERDEX,  NXTNBR, 
1  STKPTR 

real  PROPTN  (STKSIZ) 

real  CONTRB  (STKSIZ) 

real  COUNTD  (STKSIZ) 

integer  PERDEX  (STKSIZ) 

integer  NXTNBR  (STKSIZ) 

integer  STKPTR 

c    ***  end  of  declarations  for  common  data  *** 


real  CCMPRP 
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c         First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 
c         because  there  might  be  two  paths  to  an  ancestor. 
STKPTR  =  1 

PERDEX  (STKPTR)  =  INDEXl 
NXTNBR  (STKPTR)  =  0 

100  continue 

call  ZERPRO 

if  (STKPTR  .ge.  1)  goto  100 

101  continue 

c         now  mark  with  shared  PROPTN 

STKPTR  =1  . 
PERDEX  (STKPTR)  =  INDEXl 
NXTNBR  (STKPTR)  =  0 
PROPTN  (STKPTR)  =1.0 

200  continue 

call  MRKPRO  (IDENT  (INDEXl)) 
if  (STKPTR  .ge.   1)  goto  200 

201  continue 

c  traverse  ancestor  tree  for  INDEX2.   summing  overlap  with 

c         marked  tree  of  INDEXl 

COMPRP  =0.0 

STKPTR  =  1 

PERDEX  (STKPTR)  =  INDEX2 
NXTNBR  (STKPTR)  =  0 
PROPTN  (STKPTR)  =1.0 
COUNTD  (STKPTR)  =0.0 

300  continue 

call  CHKCOM  (COMPRP,   IDENT  (INDEXl)) 
if  (STKPTR  .ge.   1)  goto  300 

301  continue 

write  (unit=*,  fmt=9001)  COMPRP 
9001    formate     Proportion  of  common  genetic  material  =        Ip,  el2.5e2) 
end 

subroutine  ZERPRO 
c         ZERPRO  recursively  seeks  out  all  ancestors  and 
c  zeros  them  out . 

integer  MAXPRS,  NAMLEN,  IDLEN,  BUFLEN, 

1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,   IDLEN  =  3,  BUFLEN  =60, 

1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character    NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

integer  PARENT,  CHILD,  SPOUSE,  SIBLNG, 

1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  4, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 


These  conmon  blocks  hold  the  PERSON  array,  which  is  global  to 
the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,   RCHST,   DSCGEN,  NUMPER 

common  /PERCHR/     NAME,   IDENT,   GENDER,  RELID,  DSCID 

The  following  data  items  constitute  the  PERSON  array,  which 

is  the  central  repository  of  information  about  inter-relationship; 

static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*l  GENDER  (MAXPRS) 

IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID      (MAXPRS,  MAXGVN) 

pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX     (MAXPRS,  MAXNBR) 

Integer  NBREDG     (MAXPRS,  MAXNBR) 

data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST      (MAXPRS)  , 

data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

STACK  is  common  to  the  routines  which  calculate  genetic  overlap. 
It  is  used  to  implement  recursive  traversal  of  the  ancestor  trees 

integer  STKSIZ 
parameter  (STKSIZ  =  50) 

common  /STACK/  PROPTN,  CONTRB,  COUNTD,   PERDEX,  NXTNBR, 
1  STKPTR 


real 

real 

real 

integer 

integer 

integer 


PROPTN 
CONTRB 
COUNTD 
PERDEX 
NXTNBR 
STKPTR 


(STKSIZ) 
(STKSIZ) 
(STKSIZ) 
(STKSIZ) 
(STKSIZ) 


***  end  of  declarations  for  common  data 
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integer 


ZERDEX,  THSNBR 


ZERDEX  =  PERDEX  (STKPTR) 

if  (NXTNBR  (STKPTR)   .eq.  0)  then 

DSCGEN  (ZERDEX)  =  0.0 

NXTNBR  (STKPTR)  =  1 
end  if 

do  100  THSNBR  =  NXTNBR  (STKPTR),  NBRCNT  (ZERDEX) 

if  (NBREDG  (ZERDEX,   THSNBR)   .eq.   PARENT)  goto  101 

100  continue 

101  continue 

if  (THSNBR  .gt.  NBRCNT  (ZERDEX))  then 
c  no  more  ancestors  from  this  person 

STKPTR  =  STKPTR  -  1 
else 

c  set  up  for  next  ancestor 

NXTNBR  (STKPTR)  =  THSNBR  +  1 
STKPTR  =  STKPTR  +  1 

PERDEX  (STKPTR)  =  NBRDEX  (ZERDEX,  THSNBR) 

NXTNBR  (STKPTR)  =  0 
end  if 
end 

subroutine  MRKPRO  (MARKER) 
c         MRKPRO  recursively  seeks  out  all  ancestors  and 
c         marks  them  with  the  sender's  proportion  of  shared 
c         genetic  material.     This  proportion  is  diluted  by  one-half 
c  for  each  generation. 


integer        MAXPRS,   NAMLEN,   IDLEN,  BUFLEN, 
1  MS GLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN 
1  MS GLEN  =  40,  MAXNBR  =  20,  MAXGVN 


3,  BUFLEN 
3) 


character    NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

integer        PARENT,  CHILD,   SPOUSE,  SIBLNG, 
1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  4, 
1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 


c  These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c     the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DST3RC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 


common  /PERCHR/     NAME,   IDENT,   GENDER,  RELID,  DSCID 


The  following  data  items  constitute  the  PERSON  array,  which 

is  the  central  repository  of  information  about  inter-relationship 


static  information  -  filled 
character* (NAMLEN) 
character* (IDLEN) 
character*! 


from  PEOPLE  file 
NAME         (MAXPRS ) 
IDENT  (MAXPRS) 
GENDER  (MAXPRS) 


IDENTs  of  immediate  relatives  -  father,  mother 
character*(IDLEN)  RELID  (MAXPRS, 

pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

Integer  NBRDEX  (MAXPRS, 

integer  NBREDG  (MAXPRS, 


spouse 
MAXGVN) 


MAXNBR) 
MAXNBR) 


data  used  when  traversing  graph  to  resolve  user  request: 
real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

data  used  to  compute  common  genetic  material 
character* (IDLEN)  DSCID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 


NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

STACK  is  common  to  the  routines  which  calculate  genetic  overlap. 
It  is  used  to  implement  recursive  traversal  of  the  ancestor  trees 


integer  STKSIZ 
parameter  (STKSIZ  =  50) 

common  /STACK/  PROPTN,  CONTRB,  COUNTD,  PERDEX,  NXTNBR, 
1  STKPTR 


real 

real 

real 

integer 

integer 

integer 


PROPTN 
CONTRB 
COUNTD 
PERDEX 
NXTNBR 
STKPTR 


(STKSIZ) 
(STKSIZ) 
(STKSIZ) 
(STKSIZ) 
(STKSIZ) 


***  end  of  declarations  for  common  data  *** 


character* (IDLEN)  MARKER 
integer  MRKDEX,  THSNBR 
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MRKDEX  =  PERDEX  (STKPTR) 
if  (NXTNBR  (STKPTR)   .eq.  0)  then 
DSCID     (MRKDEX)  =  MARKER 

DSCGEN  (MRKDEX)  =  DSCGEN  (MRKDEX)  +  PROPTN  (STKPTR) 
NXTNBR  (STKPTR)  =1 
end  if 

do  100  THSNBR  =  NXTNBR  (STKPTR),  NBRCNT  (MRKDEX) 

if  (NBREDG  (MRKDEX,  THSNBR)   .eq.   PARENT)  goto  101 

100  continue 

101  continue 

if  (THSNBR  .gt.  NBRCNT  (MRKDEX))  then 
c  no  more  ancestors  from  this  person 

STKPTR  =  STKPTR  -  1 
else 

c  set  up  for  next  ancestor 

NXTNBR  (STKPTR)  =  THSNBR  +  1 
STKPTR  =  STKPTR  +  1 

PERDEX  (STKPTR)  =  NBRDEX  (MRKDEX,  THSNBR) 
NXTNBR  (STKPTR)  =0 

PROPTN  (STKPTR)  =  PROPTN  (STKPTR  -  1)  /  2.0 
end  if 
end 

subroutine  CHKCOM  (COMPRP,  MTCHID) 
C         CHKCOM  searches  all  the  ancestors  of  CHKDEX  to  see  if  any  have 
c         been  marked,  and  if  so  adds  the  appropriate  amount  to  COMPRP. 

integer        MAXPRS,  NAMLEN,   IDLEN,  BUFLEN, 
1  MSGLEN,  MAXNBR,  MAXGVN 

parameter  (MAXPRS  =  300,  NAMLEN  =  20,  IDLEN  =  3,  BUFLEN  =  60, 
1  MSGLEN  =  40,  MAXNBR  =  20,  MAXGVN  =  3) 

character     NULLID*( IDLEN) 
parameter  (NULLID  =  '000') 

integer  PARENT,  CHILD,  SPOUSE,  SIBLNG, 

1  UNCLE,  NEPHEW,  COUSIN,  NULLRL 

parameter  (PARENT  =  1,  CHILD  =  2,  SPOUSE  =  3,  SIBLNG  =  4, 

1  UNCLE  =  5,  NEPHEW  =  6,  COUSIN  =  7,  NULLRL  =  8) 


c  These  common  blocks  hold  the  PERSON  array,  which  is  global  to 
c    the  entire  program. 

common  /PERNUM/     NBRCNT,  NBRDEX,  NBREDG,  DSTSRC,  PATHPR, 
1  EDGPRD,  RCHST,   DSCGEN,  NUMPER 


common  /PERCHR/    NAME,  IDENT,  GENDER,  RELID,  DSCID 


The  following  data  items  constitute  the  PERSON  array,  which 

is  the  central  repository  of  information  about  inter-relationships 


static  information  -  filled  from  PEOPLE  file 

character* (NAMLEN)  NAME  (MAXPRS) 

character* (IDLEN)  IDENT  (MAXPRS) 

character*!  GENDER  (MAXPRS) 

IDENTs  of  immediate  relatives  -  father,  mother,  spouse 

character* (IDLEN)  RELID       (MAXPRS,  MAXGVN) 

pointers  to  immediate  neighbors  in  graph 

integer  NBRCNT  (MAXPRS) 

integer  NBRDEX    (MAXPRS,  MAXNBR) 

integer  NBREDG     (MAXPRS,  MAXNBR) 

data  used  when  traversing  graph  to  resolve  user  request: 

real  DSTSRC  (MAXPRS) 

integer  PATHPR  (MAXPRS) 

integer  EDGPRD  (MAXPRS) 

integer  RCHST  (MAXPRS) 

data  used  to  compute  common  genetic  material 

character* (IDLEN)  DSC ID  (MAXPRS) 

real  DSCGEN  (MAXPRS) 

NUMPER  keeps  track  of  the  actual  number  of  persons 
integer  NUMPER 

STACK  is  common  to  the  routines  which  calculate  genetic  overlap. 
It  is  used  to  implement  recursive  traversal  of  the  ancestor  trees 

integer  STKSIZ 
parameter  (STKSIZ  =  50) 

common  /STACK/  PROPTN,  CONTRB,  COUNTD,   PERDEX,  NXTNBR, 
1  STKPTR 

real  PROPTN  (STKSIZ) 

real  CONTRB  (STKSIZ) 

real  COUNTD  (STKSIZ) 

integer  PERDEX  (STKSIZ) 

integer  NXTNBR  (STKSIZ) 

integer  STKPTR 

***  end  of  declarations  for  common  data  *** 

real  COMPRP 
character* (IDLEN)  MTCHID 
integer  CHKDEX 
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CHKDEX  =  PERDEX  (STKPTR) 
if  (NXTNBR  (STKPTR)   .eq.  0)  then 
NXTNBR  (STKPTR)  =  1 

if  (DSCID  (CHKDEX)   .eq.  MTCHID)  then 
c  Increment  COMPRP  by  the  contribution  of  this 

c  common  ancestor,  but  discount  for  the  contribution 

c  of  less  remote  ancestors  already  counted. 

CONTRB  (STKPTR)  =  DSCGEN  (CHKDEX)  *  PROPTN  (STKPTR) 
COMPRP  =  COMPRP  +  CONTRB  (STKPTR)  -  COUNTD  (STKPTR) 
else 

CONTRB  (STKPTR)  =0.0 
end  if 
end  if 

do  100  THSNBR  =  NXTNBR  (STKPTR),  NBRCNT  (CHKDEX) 

if  (NBREDG  (CHKDEX,  THSNBR)   .eq.   PARENT)  goto  101 

100  continue 

101  continue 

if  (THSNBR  .gt.  NBRCNT  (CHKDEX))  then 
c  no  more  ancestors  from  this  person 

STKPTR  =  STKPTR  -  1 
else 

c  set  up  for  next  ancestor 

NXTNBR  (STKPTR)  =  THSNBR  +  1 
STKPTR  =  STKPTR  +  1 

PERDEX  (STKPTR)  =  NBRDEX  (CHKDEX,  THSNBR) 
NXTNBR  (STKPTR)  =  0 

PROPTN  (STKPTR)  =  PROPTN  (STKPTR  -  1)  /  2.0 
COUNTD  (STKPTR)  =  CONTRB  (STKPTR  -  1)  /  A.O 

end  if 

end 
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7.0  PASCAL 

User-defined  identifiers  are  written  in  mixed  upper  and  lower  case,  rather  than 
all  upper-case,  because  Pascal  provides  no  separator  character,  such  as  "-"  or 
"_"  for  identifiers.  Therefore,  upper-case  letters  are  used  for  readability, 
e.g.,  EdgeToPredecessor  is  used  in  Pascal  where  EDGE_TO_PREDECESSOR  is  used  in 
most  of  the  other  languages. 


program  Relate  (input,  output,  People); 
const 

MaxPersons  =  300; 

Name Length  =  20; 

{  every  Person  has  a  unique  3-digit  Identifier  } 
Identifier Length    =  3; 
BufferLength  =  60; 

RequestOk  = 

'Request  OK 
RequestToStop 

'stop 


type 

Identifier Range 

Buf f erRange 

NameRange 

Dig it Type 

Name  Type 

BufferType 

MessageType 

Identifier Type 

{  each  Person's  re 

others  directly 
Givenldentif iers 
Relative Array 
Counter 


=  1. . Identif ierLength; 
=  1 .. Buf fer Length ; 
=  1. .NameLength; 
=  '0'..'9'; 

=  packed  array  [NameRange]  of  char; 

=  packed  array  [Buf f erRange]  of  char; 

=  packed  array  [1..40]  of  char; 

=  array  [ Identif ierRange]  of  DigitType; 

cord  in  the  file  identifies  at  most  three 

related:  father,  mother,  and  spouse  } 

=  (Father Ident ,  Motherldent,  Spouseldent) ; 

=  array  [Givenldentif iers]  of  Identif ierType ; 

=  0. .maxint ; 


{  this  is  the  format  of  records  in  the  file  to  be  read  in  } 
FilePersonRecord  =  record 


Name 

Identifier 


Name Type ; 
Identif ierType ; 


{  'M'  for  Male  and  'F'  for  Female  } 


Gender 

Relative Identifier 
end; 


char; 

RelativeArray 


Page  136 


IndexType  =  0. .MaxPersons ; 

Gender Type  =  (Male,  Female); 

RelationType  =  (Parent,  Child,  Spouse,  Sibling,  Uncle, 

Nephew,  Cousin,  NullRelation) ; 
{  directed  edges  in  the  graph  are  of  a  given  type  } 
Edge Type  =  Parent .. Spouse; 

{  A  node  in  the  graph  (=  Person)  has  either  already  been  reached, 

is  immediately  adjacent  to  those  reached,  or  farther  away.  } 
ReachedType  =  (Reached,  Nearby,  NotSeen); 

{  each  Person  has  a  linked  list  of  adjacent  nodes,  called  neighbors  } 
NeighborPointer        =  "Neighbor Re cord; 

NeighborRecord  =  record 

Neighborlndex        :  IndexType; 
NeighborEdge  :  Edge Type; 

NextNeighbor  :  NeighborPointer 

end; 

{  All  Relationships  are  captured  in  the  directed  graph  of  which 

each  record  is  a  node .  } 
PersonRecord  =  record 

{  static  information  -  filled  from  People  file:  } 
Name  :  Name  Type; 

Identifier  :  Identif ierType ;  ^ 

Gender  :  GenderType; 

{  Identifiers  of  immediate  relatives  -  father,  mother,  spouse  } 

Relativeldentif ier       :  Relative Array ; 

{  head  of  linked  list  of  adjacent  nodes  } 

NeighborListHeader       :  NeighborPointer; 
{  data  used  when  traversing  graph  to  resolve  user  request:  } 

DistanceFromSource       :  real; 

PathPredecessor  :  IndexType; 

EdgeToPredecessor        :  EdgeType; 

ReachedStatus  :  ReachedType; 

{  data  used  to  compute  common  genetic  material  } 

Descendantldentif ier   :  Identif ierType ; 

DescendantGenes  :  real 

end; 


var 

{  The  Person  array  is  the  central  repository  of  information 

about  inter-relationships.  } 
Person  :  array  [IndexType]  of  PersonRecord; 

{  These  variables  are  used  when  establishing  the  Person  array 

from  the  People  file.  } 
People  :  file  of  FilePersonRecord; 

Current,  Previous,  NumberOf Persons 

:   IndexType ; 
Identif ier Index     :  Identif ierRange ; 
Previous Ident ,  Current Ident ,  Nullldent 

:  Identif ierType ; 
Relationship  :  Givenldentif iers ; 

RelationLoopDone  :  boolean; 


{  These  variables  are  used  to  accept  and  resolve  requests  for 

Relationship  information.  } 
Bufferlndex,  SemicolonLocation 

:  BufferRange; 
RequestBuf f er  :  BufferType; 

Personlldent,  Person2ldent 

:  Name Type; 
PersonlFound,  Person2Found 

:  Counter; 
ErrorMessage  :  MessageType; 

Personllndex,  Person2lndex 

:  IndexType; 

function  IdentsEqual  (Identa,  Identb:  Identif ierType)   :  boolean 
{  Determines  whether  two  numeric  Person-Identifiers  are  equal 
A  function  is  necessary  because  the  operator  does  not 

work  for  arrays  of  anything  but  char.  } 

var 

Index     :  1. . Identif ierLength; 
begin 

IdentsEqual  :=  true; 

for  Index  :=  1  to  Identif ierLength  do 

if  Identa  [Index]  <>  Identb  [Index]  then 
IdentsEqual  :=  false 
end;     {  IdentsEqual  } 
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procedure  LinkRelatives  (Fromlndex        :  IndexType; 

Relationship  :  Givenldentif iers ; 
To Index  :  IndexType); 

{  establishes  cross- indexing  between  innnediately  related  Persons.  } 

procedure  LinkOneWay  (Fromlndex  :  IndexType; 

ThisEdge  :  EdgeType; 

To Index  :  IndexType); 

{  Establishes  the  NeighborRecord  from  one  Person  to  another  } 
var 

NewNeighbor   :  Neighbor Pointer ; 
beg  in 

new  (NewNeighbor); 
with  NewNeighbor^  do 
begin 

Neighbor Index  :=  To Index; 
NeighborEdge     :=  ThisEdge; 

NextNeighbor     :=  Person  [Fromlndex]   .  NeighborListHeader 
end; 

Person  [Fromlndex]   .  NeighborListHeader  :=  NewNeighbor 
end; 

begin      {  execution  of  LinkRelatives  } 
if  Relationship  =  Spouseldent  then 
begin 

LinkOneWay  (Fromlndex,  Spouse,  To Index); 
LinkOneWay  (Toindex,  Spouse,  Fromlndex) 
end 

else      {  Relationship  is  Mother  or  Father  } 
begin 

LinkOneWay  (Fromlndex,  Parent,  Toindex); 
LinkOneWay  (Toindex,  Child,  Fromlndex) 
end 

end;     {  LinkRelatives  } 

procedure  Prompt AndRead; 

{  Issues  prompt  for  user-request,  reads  in  request, 

blank-fills  buffer,  and  skips  to  next  line  of  input.  } 

var 

Bufferlndex  :  BufferRange; 
beg  in 

writeln  ('  '); 

writeln  ('   '); 

writeln  ('  Enter  two  person-identifiers  (name  or  number),'); 
writeln  ('  separated  by  semicolon.  Enter  "stop"  to  stop.'); 
for  Bufferlndex  :=  1  to  BufferLength  do 

if  eoln( input)  then 

RequestBuf f er   [Bufferlndex]    :=  '  ' 

else 

read  (input,  RequestBuf fer  [Bufferlndex]  ); 
readln( input) 
end;       {  Prompt AndRead  } 


procedure  CheckRequest  (var  RequestStatus  :  MessageType; 

var  SemicolonLocation   :  Buf f erRange) ; 
{  Performs  syntactic  check  on  request  in  buffer.  } 
var 

Buffer Index  :  Buff erRange; 

SemicolonCount        :  Counter; 
PersonlFieldExists ,  Person2FieldExists 

:  boolean; 

beg  in 

RequestStatus  :=  RequestOk; 

PersonlFieldExists  :=  false; 
Person2FieldExists  :=  false; 
SemicolonCount  :=  0; 

for  Bufferlndex  :=  1  to  BufferLength  do 

if  RequestBuf f er  [Bufferlndex]  <>  '  '  then 
if  RequestBuf fer  [Bufferlndex]  =  ';'  then 
begin 

SemicolonLocation  :=  Bufferlndex; 
SemicolonCount        :=  SemicolonCount  +  1 
end 

else      {  Check  for  non-blanks  before/after  semicolon.  } 
if  SemicolonCount  <  1  then 

PersonlFieldExists   :=  true 
else 

Person2FieldExists  :=  true; 
{  set  RequestStatus,  based  on  results  of  scan  of  RequestBuf f 
if  SemicolonCount  <>  1  then 

RequestStatus   :=  'must  be  exactly  one  semicolon, 
else 

if  not  PersonlFieldExists  then 

RequestStatus  :-  'null  field  preceding  semicolon, 
else 

if  not  Person2FieldExists  then 

RequestStatus   :=  'null  field  following  semicolon, 
end;       {  CheckRequest  } 

procedure  Buf f erToPerson  (var  Personid  :  NameType ; 

StartLocation,  StopLocation  :  Buf f erRange) ; 
{  fills  in  the  Personid  from  the  designated  portion 
of  the  RequestBuf fer .  } 

var 

Bufferlndex  :   1..61;     {  cannot  say  "BufferLength  +  1"  } 
Per son Index  :  Name Range; 
begin 

Bufferlndex  :=  StartLocation; 

while  RequestBuf fer  [Bufferlndex]  =  '  '  do 

Bufferlndex  :=  Bufferlndex  +  1; 
for  Personlndex  :=  1  to  NameLength  do 
if  Bufferlndex  >  StopLocation  then 

Personid  [Personlndex]  :=  '  ' 
else 

begin 

Personid  [Personlndex]   :=  RequestBuf fer  [Bufferlndex]; 

Bufferlndex  :=  Bufferlndex  +  1 

end 

end;       {  Buf f erToPerson  } 
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procedure  SearchForRequestedPersons  (Personlldent ,  Person2Ident 
var  Personllndex,  Person2Index  :  IndexType; 
var  PersonlFound ,  Person2Found  :  Counter); 
{  SearchForRequestedPersons  scans  through  the  Person  array, 
looking  for  the  two  requested  persons.    Match  may  be  by  name 
or  unique  identifier-number.  } 

var 

Current  :  IndexType; 

Thisldent  :  Name Type; 

Identifier Index      :  Identif ierRange ; 
begin 

PersonlFound  :=  0; 
Person2Found  :=  0; 
Thisldent        :=  ' 

for  Current     :=  1  to  Number Of Persons  do 
with  Person  [Current]  do 
begin 

{  Thisldent  contains  Current  Person's  numeric  Identifier 

left-justified,  padded  with  blanks.  } 
for  Identif ier Index  :=  1  to  Identif ierLength  do 

Thisldent  [Identif ier Index]  :=  Identifier  [Identif ier Index] ; 
{  allow  identification  by  name  or  number.  } 
if  (Personlldent  =  Thisldent)  or  (Personlldent  =  Name)  then 


Name Type ; 


PersonlFound  + 
Current 


1; 


end: 


begin 

PersonlFound 
Personllndex 
end; 

if  (Person2ldent  =  Thisldent)  or  (Person2ldent  =  Name)  then 
beg  in 

Person2Found 
Per son 2 Index 
end 

end      {  with  Person  [Current]  } 
{  SearchForRequestedPersons  } 


Person2Found  +  1; 
Current 


procedure  FindRelationship  (Targetlndex ,  Sourcelndex  :  IndexType); 
{  Finds  shortest  path  (if  any)  between  two  Persons  and 

determines  their  Relationship  based  on  immediate  relations 
traversed  in  path.     Person  array  simulates  a  directed  graph, 
and  algorithm  finds  shortest  path,  based  on  following 
weights:  Parent-Child  edge    =  1.0 

Spouse-Spouse  edge  =1.8  } 

var 

SearchStatus  :  (Searching,  Succeeded,  Failed); 

Personlndex,  ThisNode,  AdjacentNode,  BestNearby Index,  LastNearby Index 

IndexType ; 

array  [IndexType]  of  IndexType; 
EdgeType; 
NeighborPointer ; 
Givenldentif iers ; 
real; 


NearbyNode 
ThisEdge 
ThisNeighbor 
Relationship 
MinimalDi stance 


procedure  ProcessAd jacentNode  (BaseNode,  NextNode   :  IndexType; 

NextBaseEdge  :  EdgeType); 

{  NextNode  is  adjacent  to  last-reached  node  (=  BaseNode). 
if  NextNode  already  Reached ,  do  nothing . 
If  previously  seen,  check  whether  path  thru  base  node  is 
shorter  than  current  path  to  NextNode,  and  if  so  re-link 
next  to  base . 

If  not  previously  seen,  link  next  to  base  node.  } 

var 

WeightThisEdge ,  DistanceThruBaseNode 

:  real; 

procedure  LinkNextNodeToBaseNode ; 

{  link  next  to  base  by  re-setting  its  predecessor  Index  to 
point  to  base,  note  type  of  edge,  and  re-set  distance 
as  it  is  through  base  node.  } 
begin      {  execution  of  LinkNextNodeToBaseNode  } 
with  Person  [NextNode]  do 
begin 

DistanceFromSource  :=  DistanceThruBaseNode; 
PathPredecessor        :=  BaseNode; 
EdgeTo Predecessor     :=  NextBaseEdge 
end 

end;       {  LinkNextNodeToBaseNode  } 

begin    {  execution  of  ProcessAdjacentNode  } 
with  Person  [NextNode]  do 

if  Reached Status  <>  Reached  then 
begin 

if  NextBaseEdge  =  Spouse  then 

WeightThisEdge  :=  1.8 
else 

WeightThisEdge  :=  1.0; 
DistanceThruBaseNode  :=  WeightThisEdge  + 

Person  [BaseNode]   .  DistanceFromSource; 
if  ReachedStatus  =  Not  Seen  then 

begin 

ReachedStatus      :=  Nearby; 

Last Nearby  Index  :=  LastNearby Index  +  1; 

NearbyNode  [LastNearbylndex]   :=  NextNode; 

LinkNextNodeToBaseNode 

end 

else      {  ReachedStatus  =  Nearby  } 

if  DistanceThruBaseNode  <  DistanceFromSource  then 
LinkNextNodeToBaseNode ; 
end      {  if  ReachedStatus  <>  Reached  } 
end;      {  ProcessAdjacentNode  } 
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procedure  ResolvePathTo English; 

{  ResolvePathToEnglish  condenses  the  shortest  path  to  a 
series  of  Relationships  for  which  there  are  English 
descriptions .  } 

type 

{  Key  Persons  are  the  ones  in  the  Relationship  path  which  remain 

after  the  path  is  condensed.  } 
SiblingType  =  (Step,  Half,  Full); 

KeyPersonRecord  =  record 

Personlndex       :  IndexType ; 

GenerationGap  :  Counter; 

Proximity  :  SiblingType; 

case  RelationToNext        :  RelationType  of 

Parent,  Child,  Spouse,  Sibling,  Uncle,  Nephew,  NullRelation 

:  (); 

Cousin  :  (CousinRank  :  Counter) 

end; 

var 

{  these  variables  are  used  to  condense  the  path  } 

Key Person  :  array  [IndexType]  of  KeyPersonRecord; 

KeyRelation,  LaterKeyRelation ,  PrimaryRelation,  NextPrimaryRelation 

:  RelationType; 
GenerationCount  :  Counter; 

Keylndex,  LaterKey Index ,  Primarylndex 

:  IndexType; 
AnotherElementPossible   :  boolean; 

function  FullSibling  (Indexl,   Index2  :  IndexType)   :  boolean; 
{  Determines  whether  two  Persons  are  full  siblings,  i.e., 
have  the  same  two  Parents.  } 

var 

Identlndex  :   1. . Identif ierLength; 
begin 

with  Person  [Indexl]  do 
FullSibling  := 

(not  IdentsEqual  (Relativeldentif ier  [Fatherldent] ,  Nullldent))  and 
(not  IdentsEqual  (Relat  ive Ident if ier  [Mother Ident] ,  Nullldent))  and 
(IdentsEqual  (Relativeldentif ier  [Fatherldent], 

Person  [Index2]   .  Relativeldentif ier  [Fatherldent]   ))  and 
(IdentsEqual  (Relativeldentif ier  [Motherldent] , 

Person  [Index2]   .  Relativeldentif ier  [Motherldent]  )) 
end;       {  FullSibling  } 

procedure  CondenseKeyPersons  (Atlndex  :  IndexType;  GapSize   :  Counter); 
{  CondenseKeyPersons  condenses  superfluous  entries  from  the 
KeyPerson  array,  starting  at  Atlndex.  } 

var 

Receivelndex ,  Sendlndex  :  IndexType; 
begin 

Receivelndex  :=  Atlndex; 
repeat 

Receivelndex  :=  Receivelndex  +1; 
Sendlndex        :=  Receivelndex  +  GapSize; 
KeyPerson  [Receivelndex]   :=  KeyPerson  [Sendlndex]; 
until  KeyPerson  [Sendlndex]   .  RelationToNext  =  NullRelation 
end;       {  CondenseKeyPersons  } 


procedure  DisplayRelation  (Firstlndex,  Lastlndex,  Primarylndex 

:  IndexType); 

{  DisplayRelation  takes  1,  2,  or  3  adjacent  elements  in  the 
condensed  table  and  generates  the  English  description  of 
the  relation  between  the  first  and  last  +  1  elements.  } 

var 

Inlaw  :  boolean; 

ThisProximity  :   Sibling Type; 

ThisGender  :  GenderType ; 

Suf f ixindicator      :  0..9; 

FirstRelation ,  LastRelation ,  PrimaryRelation 

:  RelationType ; 
This  Generat  ion Gap ,  This  Cous inRank 

:  Counter; 

begin      {  execution  of  DisplayRelation  } 

FirstRelation  :=  KeyPerson  [Firstlndex]  .  RelationToNext ; 
LastRelation  :=  KeyPerson  [Lastlndex]         .  RelationToNext; 

PrimaryRelation     :=  KeyPerson  [Primarylndex]   .  RelationToNext; 
{  set  ThisProximity  } 

if  ((PrimaryRelation  =  Parent)  and  (FirstRelation  =  Spouse))  or 

((PrimaryRelation  =  Child)     and  (LastRelation    =  Spouse)) 
then 

ThisProximity  :=  Step 
else 

if  PrimaryRelation  in 

[Sibling,  Uncle,  Nephew,  Cousin] 
then 

ThisProximity  :=  KeyPerson  [Primarylndex]   .  Proximity 
else 

ThisProximity  :=  Full; 
{  set  This Generation Gap  } 

if  PrimaryRelation  in  [Parent,  Child,  Uncle,  Nephew,  Cousin] 
then 

ThisGenerationGap  :=  KeyPerson  [Primarylndex]   .  GenerationGap 
else 

ThisGenerationGap  :=  0; 
{  set  Inlaw  } 
Inlaw  :=  false; 

if  (FirstRelation  =  Spouse)  and 

(PrimaryRelation  in  [Sibling,  Child,  Nephew,  Cousin]  ) 
then 

Inlaw  :=  true; 
if  (LastRelation  =  Spouse)  and 

(PrimaryRelation  in  [Sibling,  Parent,  Uncle,  Cousin]  ) 
then 

Inlaw  : =  true ; 
{  set  This Cous inRank  } 
if  PrimaryRelation  =  Cousin  then 

This Cous inRank  :=  KeyPerson  [Primarylndex]  .  CousinRank 
else 

ThisCousinRank  :=  0; 
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{  parameters  are  set  -  now  generate  display.  } 


write  ('        Person  [KeyPerson  [Firstlndex]  .  Personlndex]   .  Name, 
is  '); 

if  PrimaryRelation  in  [Parent,  Child,  Uncle,  Nephew]  then 
begin      {  write  generation-qualifier  } 
if  ThisGenerationGap  >=  3  then 
begin 

write  ('great'); 

if  ThisGenerationGap  >  3  then 

write  ('*',  ThisGenerationGap  -  2  :  1); 
write  ('-') 
end; 

if  ThisGenerationGap  >=  2  then 
write  ('grand-') 

end 
else 

if  (PrimaryRelation  =  Cousin)  and  (ThisCousinRank  >  1)  then 
begin 

write  (ThisCousinRank  :  1); 

Suf f ixindicator  :=  ThisCousinRank  mod  10; 

case  Suf f ixindicator  of 

1  :  write  ('st  ') 

2  :  write  ('nd  '); 

3  :  write  ('rd  ') 
0,  4,  5,  6,  7,  8,  9 

:  write  ('th  ') 
end 
end; 


if  ThisProximity  =  Step  then 

write  ('step-') 
else 

if  ThisProximity  =  Half  then 
write  ('half-'); 


ThisGender  :=  Person  [KeyPerson 
case  PrimaryRelation  of 


[Firstlndex]   .  Personlndex]   .  Gender 


Parent  : 

Child  : 

Spouse  : 

Sibling  : 

Uncle      ^  : 

Nephew  : 

Cousin  : 

NullRelation  : 

end;       {  case  } 


if  ThisGender  = 
else 

if  ThisGender  = 
else 

if  ThisGender  = 
else 

if  ThisGender  = 
else 

if  ThisGender  = 
else 

if  ThisGender  = 
else 

write  ('cousin' 
write  ('null') 


Male  then  write 
write 

Male  then  write 
write 

Male  then  write 
write 

Male  then  write 
write 

Male  then  write 
write 

Male  then  write 
write 

); 


'father') 
'mother' ); 
'son' ) 

'daughter'); 
'husband' ) 
'wif e' ) ; 
'brother' ) 
' sister' ) ; 
'uncle' ) 
'aunt' ) ; 
'nephew' ) 
'niece'); 


If  Inlaw  then 

write  ('-in-law'); 


if  (PrimaryRelation  =  Cousin)  and  (ThisGenerationGap  >  0)  then 
if  ThisGenerationGap  >  1  then 

write  ('  ',  ThisGenerationGap  :   1,   '  times  removed') 
else 

write  ('  once  removed'); 

writeln  ('  of) 
end;       {  DisplayRelation  } 

begin      {  execution  of  ResolvePathToEnglish  } 

writeln  ('  Shortest  path  betwe  en  identified  persons:  '); 
ThisNode     :=  Target  Index; 
Key Index     :=  1; 

{  Display  path  and  initialize  KeyPerson  array  from  path  elements 
while  ThisNode  <>  Sourcelndex  do 
with  Person  [ThisNode]  do 
begin 

write  ('  ',  Name,  '  is  '); 
case  EdgeToPredecessor  of 

Parent   :  writeln  ('parent  of); 

Child     :  writeln  ('child  of); 

Spouse  :  writeln  ('spouse  of) 
end; 


KeyPerson  [Keylndex]  .  Personlndex  := 
KeyPerson  [Keylndex]  .  RelationToNext  := 
if  EdgeToPredecessor  =  Spouse  then 

KeyPerson  [Keylndex]   .  GenerationGap 
else      {  Parent  or  Child  } 

KeyPerson  [Keylndex]  .  GenerationGap 
Keylndex  :=  Keylndex  +  1; 
ThisNode  :=  PathPredecessor 
end; 

writelnC  ',  Person  [ThisNode]   .  Name); 
KeyPerson  [Keylndex]  .  Personlndex  := 

KeyPerson  [Keylndex]  .  RelationToNext  :  = 

KeyPerson  [Keylndex  +1]  .  RelationToNext  := 


ThisNode; 

EdgeToPredecessor ; 
;=  0 
;=  1; 


ThisNode; 

NullRelation; 

NullRelation; 
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{  Resolve  Child-Parent  and  Child-Spouse-Parent  relations 

to  Sibling  relations.  } 
Keylndex  :=  1; 

while  KeyPer  son  [Keylndex]   •  RelationToNext  Ky  NullRelation  do 
with  KeyPerson  [Keylndex]  do 
begin 

if  RelationToNext  =  Child  then 
begin 

LaterKeyRelation  :=  KeyPerson  [Keylndex  +1]  .  RelationToNext; 
if  LaterKeyRelation  =  Parent  then 

{  found  either  full  or  half  siblings  } 

begin 

RelationToNext  :=  Sibling; 
if  FullSibling  (Personlndex, 

KeyPerson  [Keylndex  +2]   .  Personlndex) 
then 

Proximity  :=  Full 
else 

Proximity  :=  Half; 
CondenseKeyPersons  (Keylndex,  1) 
end      {  processing  of  full/half  siblings  } 
else 

if  (LaterKeyRelation  =  Spouse)  and 

(KeyPerson  [Keylndex  +2]   .  RelationToNext  =  Parent) 
then  {  found  step-siblings  } 

begin 

RelationToNext  :=  Sibling; 
Proximity  :=  Step; 

CondenseKeyPersons  (Keylndex,  2) 
end      {  processing  of  step-siblings  } 
end;       {  if  RelationToNext  =  Child  } 
Keylndex  :=  Keylndex  +  1 
end;       {  with  KeyPerson  [Keylndex]  } 
{  Resolve  Child-Child-...  and  Parent-Parent-...  relations  to 

direct  descendant  or  ancestor  relations.  } 
Keylndex  :=  1; 

while  KeyPerson  [Keylndex]   .  RelationToNext  <>  NullRelation  do 
with  KeyPerson  [Keylndex]  do 
begin 

if  (RelationToNext  =  Child)  or  (RelationToNext  =  Parent)  then 
begin 

LaterKey Index  :=  Keylndex  +  1; 

while  KeyPerson  [LaterKey Index]   .  RelationToNext  = 
RelationToNext  do 
LaterKey Index  :=  LaterKey Index  +  1; 
GenerationCount   :=  LaterKeylndex  -  Keylndex; 
if  GenerationCount  >  1  then 

begin     {  compress  generations  } 
GenerationGap  :=  GenerationCount; 

CondenseKeyPersons  (Keylndex,  GenerationCount  -  1) 
end 

end;       {  if  RelationToNext  =  Child  or  Parent  } 
Keylndex  :=  Keylndex  +  1 
end;       {  with  KeyPerson  [Keylndex]  } 
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{  Resolve  Child-Sib.Ting-Parent  to  Cousin, 

Child-Sibling  to  Nephew, 

Sibling-Parent  to  Uncle.  } 

Key  Index  1; 

while  KeyPerson  [Keylndex]   .  RelationToNext  <>  NullRelation  do 
with  KeyPerson  [Keylndex]  do 
begin 

LaterKeyRelation  :=  KeyPerson  [Keylndex  +  1]  .  RelationToNext; 
if  (RelationToNext  =  Child)  and 
(LaterKeyRelation  =  Sibling) 
then      {  Cousin  or  Nephew  } 

if  KeyPerson  [Keylndex  +2]  .  RelationToNext  =  Parent  then 
{  found  Cousin  } 
begin 

RelationToNext  :=  Cousin; 

Proximity  :=  KeyPerson  [Keylndex  +1]   .  Proximity; 

if  GenerationCap  <  KeyPerson  [Keylndex  +2]  .  GenerationGap 

then 

CousinRank  :=  GenerationGap 
else 

CousinRank  :=  KeyPerson  [Keylndex  +2]   .  GenerationGap; 
GenerationGap  :=  abs  (GenerationGap  - 

KeyPerson  [Keylndex  +2]   .  GenerationGap); 
CondenseKey Per sons  (Keylndex,  2) 
end 

else     {  found  Nephew  } 
begin 

RelationToNext  :=  Nephew; 

Proximity  :=  KeyPerson  [Keylndex  +  1]   .  Proximity; 

CondenseKey Per sons  (Keylndex,  1) 

end 

else      {  not  Cousin  or  Nephew  } 

if  (RelationToNext  =  Sibling)  and  (LaterKeyRelation  =  Parent) 
then      {  found  Uncle  } 
begin 

RelationToNext  :=  Uncle; 

GenerationGap     :=  KeyPerson  [Keylndex  +  1]   •  GenerationGap; 

CondenseKey Persons  (Keylndex,  1) 

end; 

Keylndex  :=  Keylndex  +  1 

end;       {  with  KeyPerson  [Keylndex]  } 
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{  Loop  below  will  pick  out  valid  adjacent  strings  of  elements 
to  be  displayed.     Key Index  points  to  first  element, 
LaterKeylndex  to  last  element,  and  Primarylndex  to  the 
element  which  determines  the  primary  English  word  to  be  used. 
Associativity  of  adjacent  elements  in  condensed  table 
is  based  on  English  usage.  } 

Key Index  :=  1; 

writeln  ('  Condensed  path:'); 

while  KeyPerson  [Keylndex]   .  RelationToNext  <>  NullRelation  do 
begin 

KeyRelation      :=  KeyPerson  [Keylndex]   .  RelationToNext; 
LaterKeylndex  :=  Keylndex; 
Primarylndex     :=  Keylndex; 

if  KeyPerson  [Keylndex  +  1]  .  RelationToNext  <>  NullRelation  then 
begin      {  seek  multi-element  combination  } 
AnotherElementPossible   :=  true; 
if  KeyRelation  =  Spouse  then 
begin 

LaterKeylndex  :=  LaterKeylndex  +  1; 
Primarylndex     :=  LaterKeylndex; 

if  (KeyPerson  [LaterKeylndex]   .  RelationToNext  =  Sibling)  or 
(KeyPerson  [LaterKeylndex]   .  RelationToNext  =  Cousin) 

then      {  Nothing  can  follow  Spouse-Sibling  or  Spouse-Cousin  } 
AnotherElementPossible  :=  false 

end; 

{  Primarylndex  is  now  correctly  set.     Next  if-statement 
determines  if  a  following  Spouse  relation  should  be 
appended  to  this  combination  or  left  for  the  next 
combination.  } 
if  AnotherElementPossible  and 

(KeyPerson  [Primarylndex  +1]   .  RelationToNext  =  Spouse) 
{  Only  a  Spouse  can  follow  a  Primary  } 
then 

begin     {  check  primary  preceding  and  following  Spouse.  } 
PrimaryRelation  := 

KeyPerson  [Primarylndex]   .  RelationToNext; 
NextPrimaryRelation  := 

KeyPerson  [Primarylndex  +2]  .  RelationToNext; 
if  (NextPrimaryRelation  in  [Nephew,  Cousin,  NullRelation]  ) 
or  (PrimaryRelation  =  Nephew) 
or  (   (  PrimaryRelation  in  [Sibling,  Parent]  ) 
and  (NextPrimaryRelation  <>  Uncle  )  ) 
then    {  append  following  Spouse  with  this  combination.  } 

LaterKeylndex  :=  LaterKeylndex  +  1 
end    {  check  primary  preceding  and  following  Spouse  } 
end;     {  multi-element  combination  } 
DisplayRelation  (Keylndex,  LaterKeylndex,  Primarylndex); 
Keylndex  :=  LaterKeylndex  +  1 
end;      {  while  } 

writeln  ('        Person  [KeyPerson  [Keylndex]   .  Personlndex]   .  Name) 
end;    ,  {  ResolvePathToEnglish  } 


procedure  Compute CommonGenes  (Indexl,  Index2  :  IndexType); 
{  Compute CommonGenes  assumes  that  each  ancestor  contributes 
half  of  the  genetic  material  to  a  Person.     It  finds  common 
ancestors  between  two  Persons  and  computes  the  expected 
value  of  the  Proportion  of  common  material.  } 

var 

CommonProportion  :  real; 

procedure  ZeroProportion  (Zerolndex  :  IndexType); 

{  ZeroProportion  recursively  seeks  out  all  ancestors  and 
zeros  them  out.  } 

var 

ThisNelghbor  :  NeighborPolnter ; 
begin 

with  Person  [Zerolndex]  do 
begin 

DescendantGenes  :=  0.0; 

ThisNelghbor        :=  Neighbor LlstHeader 

end; 

while  ThisNelghbor  <>  nil  do 
with  ThisNelghbor"  do 
begin 

if  NeighborEdge  =  Parent  then 

ZeroProportion  (Neighbor Index) ; 
ThisNelghbor  :=  NextNeighbor 
end      {  with  } 
end;       {  ZeroProportion  } 

procedure  MarkProportion  (Marker  :  Identlf lerType ; 

Proportion  :  real;  Markedlndex  :  IndexType); 
{  MarkProportion  recursively  seeks  out  all  ancestors  and 
marks  them  with  the  sender's  Proportion  of  shared 
genetic  material.     This  Proportion  is  diluted  by  one-half 
for  each  generation.  } 

var 

ThisNelghbor  :  NeighborPolnter; 
begin 

with  Person  [Markedlndex]  do 
begin 

Descendantldentif ier  :=  Marker; 

DescendantGenes  :=  DescendantGenes  +  Proportion; 

ThisNelghbor  :=  NeighborLlstHeader 

end; 

\ih±le  ThisNelghbor  <>  nil  do 
with  ThisNelghbor"  do 
begin 

if  NeighborEdge  =  Parent  then 

MarkProportion  (Marker,  Proportion  /  2.0, 
Neighborlndex  ); 
ThisNelghbor  :=  NextNeighbor 
end 

end;       {  MarkProportion  } 


Page  150 


procedure  CheckCommonProportion 

(var  CommonProportlon  :  real; 

Matchldentif ier     :  Identif ierType ; 
Proportion  :  real; 

AlreadyCounted       :  real; 
Checklndex  :  IndexType); 

{  CheckCommonProportion  searches  all  the  ancestors  of 
Checklndex  to  see  if  any  have  been  marked,  and  if  so 
adds  the  appropriate  amount  to  CommonProportlon.  } 

var 

ThisNeighbor  :  NeighborPointer ; 

ThisContribution  :  real; 
begin 

with  Person  [Checklndex]  do 
begin 

if  IdentsEqual  (Descendantldentif ier ,  Matchldentif ier )  then 
begin 

{  Increment  CommonProportlon  by  the  contribution  of 

this  common  ancestor,  but  discount  for  the  contribution 
of  less  remote  ancestors  already  counted.  } 

ThisContribution  :=  DescendantGenes  *  Proportion; 

CommonProportlon  :=  CommonProportlon  + 

ThisContribution  -  AlreadyCounted 

end 
else 

ThisContribution  :=  0.0; 
ThisNeighbor  :=  NeighborListHeader 
end;       {  with  Person  [Checklndex]  } 
while  ThisNeighbor  O  nil  do 
with  ThisNeighbor"  do 
beg  in 

if  NeighborEdge  =  Parent  then 

CheckCommonProportion  (CommonProportlon , 

Matchldentif ier ,  Proportion  /  2.0, 

ThisContribution  /  4.0, 

Neighborlndex  ); 
ThisNeighbor  :=  NextNeighbor 
end 

end;       {  CheckCommonProportion  } 

begin      {  ComputeCommonGenes  } 

{  First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 

because  there  might  be  two  paths  to  an  ancestor.  } 
ZeroProportion  (Indexl); 
{  now  mark  with  shared  Proportion  } 

MarkProportion  (  Person  [Indexl]   .  Identifier,  1.0,  Indexl); 
CommonProportlon  :=  0.0; 
CheckCommonProportion  (CommonProportlon , 

Person  [Indexl]   .  Identifier,   1.0,  0.0,  Index2); 
writeln  ('  Proportion  of  common  genetic  material  = 
CommonProportlon  :  12) 
end;       {  ComputeCommonGenes  } 


begin      {  execution  of  FindRelationshlp  } 
{     initialize  Person-array  for  processing  - 

mark  all  nodes  as  not  seen  } 
for  Personlndex  :=  1  to  NumberOf Persons  do 

Person  [Personlndex]   .  ReachedStatus  :=  NotSeen; 
{  mark  source  node  as  Reached  } 
ThisNode  :=  Sourcelndex; 
with  Person  [ThisNode]  do 
begin 

ReachedStatus  :=  Reached; 

DistanceFromSource  :=  0.0 
end; 

{  no  Nearby  nodes  exist  yet  } 

Last Nearby Index  :=  0; 

if  ThisNode  =  Targetlndex  then 

SearchStatus  :=  Succeeded 
else 

SearchStatus   :=  Searching; 
{  Loop  keeps  processing  closest-to-source ,  unreached  node 

until  target  Reached,  or  no  more  connected  nodes.  } 
while  SearchStatus  =  Searching  do 

begin 

{  Process  all  nodes  adjacent  to  ThisNode  } 
ThisNeighbor  :=  Person  [ThisNode]  .  NeighborListHeader ; 
while  ThisNeighbor  <>  nil  do 
with  ThisNeighbor"  do 
begin 

ProcessAd jacentNode  (ThisNode,  Neighborlndex ,  NeighborEdge) ; 

ThisNeighbor  :=  NextNeighbor 

end; 

{  All  nodes  adjacent  to  ThisNode  are  set.     Now  search  for 

shortest-distance  unreached  (but  Nearby)  node  to  process  next, 
if  LastNearbylndex  =  0  then 

SearchStatus  :=  Failed 
else 

begin 

MinimalDistance  :=  l.Oe+18; 
for  Personlndex  :=  1  to  LastNearbylndex  do 
with  Person  [NearbyNode  [Personlndex]]  do 

if  DistanceFromSource  <  MinimalDistance  then 
begin 

BestNearbylndex  :=  Personlndex; 
MinimalDistance  :=  DistanceFromSource 
end; 

{  Establish  new  ThisNode  } 

ThisNode  :=  NearbyNode  [BestNearbylndex]; 

{  change  ThisNode  from  being  Nearby  to  Reached  } 

Person  [ThisNode]   .  ReachedStatus  :=  Reached; 

{  remove  ThisNode  from  Nearby  list  } 

NearbyNode  [BestNearbylndex]  :=  NearbyNode  [LastNearbylndex]; 
LastNearbylndex  :=  LastNearbylndex  -  1; 
if  ThisNode  =  Targetlndex  then 

SearchStatus   :=  Succeeded 
end      {  determination  of  next  node  to  process  } 
end;       {  while  SearchStatus  =  Searching  } 


Page  152 


{  Shortest  path  between  Persons  now  established.    Next  task  is 
to  translate  path  to  English  description  of  Relationship.  } 

if  SearchStatus  =  Failed  then 

writeln  ('        Person  [Targetlndex]   .  Name,  '  is  not  related  to 
Person  [ Sourcelndex]   .  Name) 
else      {  success  ~  parse  path  to  find  and  display  Relationship  } 

beg  in 

ResolvePathToEnglish; 

ComputeCommonGenes  (Sourcelndex,  Targetlndex) 
end 

end;       {  FindRelationship  } 

{  ***  execution  of  main  sequence  begins  here  ***  } 
begin 

for  Identif ierlndex  :=  1  to  Identif ierLength  do 

Nullldent  [Identif ierlndex]  :=  '0'; 
reset  (People); 

{  Current  location  in  array  being  filled  } 
Current  :=  0; 

{  This  loop  reads  in  the  People  file  and  constructs  the  Person 
array  from  it  (one  Person  =  one  record  =  one  array  entry). 
As  records  are  read  in,  links  are  constructed  to  represent  the 
Parent-Child  or  Spouse  relationship.     The  array  then  implements 
a  directed  graph  which  is  used  to  satisfy  subsequent  user 
requests.     The  file  is  assumed  to  be  correct  -  no  validation 
is  performed  on  it.  } 

while  not  eof (People)  do 
begin 

Current   :=  Current+1; 
with  Person  [Current]  do 
begin 

{  copy  direct  information  from  file  to  array  } 
Name  :=  People''  .  Name; 

Identifier       :=  People"  .  Identifier; 
if  People"  .  Gender  =  'M'  then 

Gender   :=  Male 
else 

Gender  :=  Female; 
Relativeldentif ier       :=  People"  .  Relativeldentif ier ; 
{  Location  of  adjacent  persons  as  yet  undetermined  } 
NeighborListHeader       :=  nil; 
{  Descendants  as  yet  undetermined.  } 
Descendantldentif ier  :=  Nullldent; 
Current Ident  :=  Identifier; 


{  Compare  this  Person  against  all  previously  entered  Persons 

to  search  for  Relationships.  } 
for  Previous  :=  1  to  (Current-1)  do 

begin 

Previous Ident  :=  Person  [Previous]   .  Identifier; 

RelatlonLoopDone       :=  false; 
Relationship  :=  Fatherldent; 

{  Search  for  father,  mother,  or  spouse  Relationship  in 
either  direction  between  this  and  previous  Person. 
Assume  at  most  one  Relationship  exists.  } 

repeat 

If  IdentsEqual  (Relatlveldentlf ier  [Relationship], 
Previous Ident)  then 

begin 

LlnkRelatlves  (Current,  Relationship,  Previous); 
RelatlonLoopDone  :=  true 
end 
else 

If  IdentsEqual  (Currentldent , 

Person  [Previous]  .  Relatlveldentlf ier  [Relationship]) 
then 

begin 

LlnkRelatlves  (Previous,  Relationship,  Current); 

RelatlonLoopDone  :=  true 

end; 

If  Relationship  <  Spouseldent  then 

Relationship  :=  succ(Relatlonship) 
else 

RelatlonLoopDone  :=  true; 
until  RelatlonLoopDone 
end;       {  for  Previous  } 
get(People) 

end      {  with  Person  [Current]  } 
end;     {  while  not  eof (People)  } 
NumberOf Persons  :=  Current; 

{  Person  array  Is  now  loaded  and  edges  between  Immediate  relatives 
(Parent-Child  or  Spouse-Spouse)  are  established. 

While-loop  accepts  requests  and  finds  Relationship  (if  any) 
between  pairs  of  Persons.  } 
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reset( Input) ; 
Prompt AndRead ; 

while  RequestBuf f er  <>  RequestToStop  do 

{  The  following  code  retrieves  and  validates  a  user  request 

for  the  Relationship  between  two  identified  Persons.  } 
begin 

CheckRequest  (ErrorMessage ,  SemicolonLocation) ; 

{  Syntax  check  of  request  completed.     Now  either  display  error 
message  or  search  for  the  two  Persons.  } 

if  ErrorMessage  =  RequestOk  then 

begin      {  Request  syntactically  correct  - 
search  for  requested  Persons.  } 
Buf f erToPerson  (Personlldent ,  1,  SemicolonLocation  -  1); 
Buf f erToPerson  (Person2ldent ,   SemicolonLocation  +  1,  Buf f erLength) ; 
SearchForRequestedPersons  (Personlldent,  Person2Ident , 

Per s on 1 Index,  Per son 2 Index, 
PersonlFound ,  Person2Found) ; 
if  (PersonlFound  =1)  and  (Person2Found  =1)  then 
{  Exactly  one  match  for  each  Person  -  proceed  to 

determine  Relationship,  if  any.  } 
if  Personllndex  =  Person2lndex  then 
begin 

write  ('        Person  [Personllndex]   .  Name, 

is  identical  to  '); 
if  Person  [Personllndex]   .  Gender  =  Male  then 

writeln('himself . ') 
else 

writeln( 'herself ) 

end 
else 

FindRelationship  (Personllndex,  Person2lndex) 
else      {  either  not  found  or  more  than  one  found  } 
begin 

if  PersonlFound  =  0  then 

writeln  ('  First  person  not  found.') 
else 

if  PersonlFound  >  1  then 

writeln  ('  Duplicate  names  for  first  person  -  use', 
numeric  identifier.'); 
if  Person2Found  =  0  then 

writeln  ('  Second  person  not  found.') 
else 

if  Person2Found  >  1  then 

writeln  ('  Duplicate  names  for  second  person  -  use', 
numeric  identifier.') 

end 

end      {  processing  of  syntactically  legal  request  } 
else 

writeln  ('  Incorrect  request  format:  ',  ErrorMessage); 
Prompt AndRead 

end;       {  while  RequestBuf fer  } 
writeln  ('  End  of  relation-finder.'); 


end . 
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8.0  PL/I 

In  keeping  with  the  general  convention  of  the  examples,  language-supplied 
keywords  and  identifiers  are  written  in  lower  case  in  the  program.  To  conform 
strictly  to  the  PL/I  standard,  however,  programs  must  use  only  upper-case 
letters.  In  the  following  program,  the  logical  "Not"  operator  is  represented  by 
the  graphic  character 


RELATE:  procedure  options  (main); 
/*  Begin  declaration  of  global  data  */ 
declare 

/*  Used  to  index  relative  array,  pointing  to  immediate  relatives  */ 
(  FATHER_IDENT  initial  (1), 

MOTHER_IDENT  initial  (2), 

SPOUSE_IDENT  initial  (3), 

/*  Used  as  mnemonics  to  represent  basic  English-word  relationships.  */ 

PARENT  initial  (1), 

CHILD  initial  (2), 

SPOUSE  initial  (3), 

SIBLING  initial  (4), 

UNCLE  initial  (5), 

NEPHEW  initial  (6), 

COUSIN  initial  (7), 

NULL_RELATION  initial  (8), 

/*  Used  as  mnemonics  to  represent  status  of  nodes  during  search 

for  shortest  path  thru  graph.  */ 
REACHED  initial  (1), 

NEARBY  initial  (2), 

NOT_SEEN  initial  (3)  ) 

fixed  binary  (4,0), 

/*  Used  as  mnemonics  to  represent  truth-values  */ 
(  TRUE  initial  ('I'b), 

FALSE  initial  ('O'b)) 

bit  (1), 

/*  Used  to  control  user  requests.  */ 

(  REQUEST_OK  character  (10)  initial  ('Request  OK'), 

REQUEST_TO_STOP      character     (4)  initial  ('stop')), 

/*  Used  as  mnemonics  to  represent  GENDER  */ 
(  MALE  initial  ('M'), 

FEMALE  initial  ('F')) 

character  (1); 
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declare 

/*  the  PERSON  array  is  the  central  repository  of  information 

about  inter-relationships .  */ 
/*  All  relationships  are  captured  in  the  directed  graph  of  which 
each  record  is  a  node .  */ 
01  PERSON  dimension  (1:300), 

/*  static  information  -  filled  from  PEOPLE  file:  */ 
05    NAME  character  (20), 

05    IDENTIFIER  picture  '999', 

05    GENDER  character  (1), 

/*  IDENTIFIERS  of  immediate  relatives  -  father,  mother,  spouse 
05    RELATIVE_IDENTIFIER  (1:3) 

picture  '999', 
/*  head  of  linked  list  of  adjacent  nodes  */ 
05    NEIGHBOR_LIST_HEADER  pointer, 

/*  data  used  when  traversing  graph  to  resolve  user  request:  */ 

05     DISTANCE_FROM_SOURCE       float  decimal  (6), 

05    PATH_PREDECESSOR  fixed  binary  (10,0), 

05    EDGE_T0_PREDECESS0R        fixed  binary  (4,0), 

05    REACHED_STATUS  fixed  binary  (4,0), 

/*  data  used  to  compute  common  genetic  material  */ 

05     DESCENDANT_IDENTIFIER    picture  '999', 

05    DESCENDANT  GENES  float  decimal  (6); 


declare 

/*  each  PERSON  has  a  linked  list  of  adjacent  nodes,  called  neighbors  */ 
01  NEIGHBOR_RECORD  based  (NEW_NEIGHBOR) , 

05  NEIGHBOR_INDEX        fixed  binary  (10,0), 

05  NEIGHBOR_EDGE  fixed  binary  (4,0), 

05  NEXT_NEIGHB0R  pointer; 

/*  End  declaration  of  global  data.  */ 


declare 

/*  This  is  the  format  of  records  in  the  file  to  be  read  in.  */ 
01  PE0PLE_REC0RD, 

05  NAME  character  (20), 

05  IDENTIFIER  picture  '999', 

/*  'M'  for  MALE  and  'F'  for  FEMALE  */ 

05  GENDER  character  (1), 

05  RELATIVE_IDENTIFIER  (1:3)  picture  '999'; 

declare 

/*  These  variables  are  used  when  establishing  the  PERSON  array 

from  the  PEOPLE  file.  */ 
PEOPLE  file  record  sequential  input, 

(CURRENT,   PREVIOUS,  NUMBER_OF_PERSONS ) 

fixed  binary  (10,0), 
(PREVIOUS_IDENT,  CURRENT_IDENT) 

picture  '999', 

NULL_IDENT  picture  '999'  static  initial  (000), 

RELATIONSHIP  fixed  binary  (4,0), 

RELATI0N_L00P_D0NE  bit  (1), 
END  OF  PEOPLE  bit  (1); 
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declare 

/*  These  variables  are  used  to  accept  and  resolve  requests  for 

RELATIONSHIP  Information.  */ 
sysin  file  record  input  environment  (AREAD), 
(BUFFER_INDEX,  SEMICOLON_LOCATION) 

fixed  binary  (10,0), 
REQUEST_BUFFER        character  (60)  varying, 
(PERS0N1_IDENT,  PERS0N2_IDENT) 

character  (20), 
( PERSON 1_F0UND,  PERS0N2_F0UND) 

fixed  binary  (10,0), 
ERR0R_MESSAGE  character  (40), 

(PERS0N1_INDEX,  PERS0N2_INDEX) 

fixed  binary  (10,0); 

/*  This  on-block  captures  exceptions  from  the  following  code  */ 
on  end file  (PEOPLE) 
begin; 

END_OF_PEOPLE  =  TRUE; 
end; 
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/*  ***  begin  execution  of  main  sequence  RELATE  ***  */ 

open  file  (PEOPLE)  title  ('PEOPLE.DAT'); 
END_OF_PEOPLE  =  FALSE; 

/*  This  loop  reads  in  the  PEOPLE  file  and  constructs  the  PERSON 
array  from  it  (one  PERSON  =  one  record  =  one  array  entry). 
As  records  are  read  in,  links  are  constructed  to  represent  the 
PARENT -CHILD  or  SPOUSE  RELATIONSHIP.     The  array  then  implements 
a  directed  graph  which  is  used  to  satisfy  subsequent  user 
requests.     The  file  is  assumed  to  be  correct  -  no  validation 
is  performed  on  it.  */ 
read  file  (PEOPLE)  into  (PEOPLE_RECORD) ; 
READ_IN_PEOPLE: 

do  CURRENT  =  1  to  300  while  (~  END_OF_PEOPLE); 
/*  copy  direct  information  from  file  to  array  */ 
PERSON  (CURRENT)  =  PEOPLE_RECORD,  by  name; 
/*  Location  of  adjacent  persons  as  yet  undetermined.  */ 
PERSON  (CURRENT)   .  NEIGHBOR_LIST_HEADER  =  null(); 
/*  Descendants  as  yet  undetermined  */ 

PERSON  (CURRENT)   .  DESCENDANT_IDENTIFIER  =  NULL_IDENT; 

CURRENT_IDENT  =  PERSON  (CURRENT)   .  IDENTIFIER; 

/*  Compare  this  PERSON  against  all  previously  entered  PERSONS 

to  search  for  RELATIONSHIPS.  */ 
COMPARE_TO_PREVIOUS : 

do  PREVIOUS  =  1  to  (CURRENT-1); 

PREVIOUS_IDENT  =  PERSON  (PREVIOUS)   .  IDENTIFIER; 

RELATION_LOOP_DONE     =  FALSE; 

/*  Search  for  father,  mother,  or  spouse  relationship  in 
either  direction  between  this  and  PREVIOUS  PERSON. 
Assume  at  most  one  RELATIONSHIP  exists.  */ 
TRY_ALL_RELATIONSHIPS : 

do  RELATIONSHIP  =  FATHER_IDENT  to  SPOUSE_IDENT 
while  C  RELATION_LOOP_DONE  )  ; 
if  PERSON  (CURRENT)   .  RELATIVE_IDENTIFIER  (RELATIONSHIP)  = 
PREVIOUS_IDENT  then 

do ; 

call  LINK_RELATIVES  (CURRENT,  RELATIONSHIP,  PREVIOUS); 
RELATION_LOOP_DONE  =  TRUE; 
end; 
else 

if  CURRENT_IDENT  = 

PERSON  (PREVIOUS)   .  RELATIVE_IDENTIFIER  (RELATIONSHIP) 
then 

do ; 

call  LINK_RELATIVES  (PREVIOUS,  RELATIONSHIP,  CURRENT); 

RELATION_LOOP_DONE  =  TRUE; 

end; 

end  TRY_ALL_RELATIONSHIPS ; 

end  COMPARE_TO_PREVIOUS; 

read  file  (PEOPLE)  into  (PEOPLE_RECORD) ; 
end  READ_IN_PEOPLE ; 
NUMBER_OF_PERSONS  =  CURRENT  -  1; 
close  file  (PEOPLE); 

/*  PERSON  array  is  now  loaded  and  edges  between  immediate  relatives 
(PARENT -CHILD  or  SPOUSE -SPOUSE)  are  established. 
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While-loop  accepts  requests  and  finds  RELATIONSHIP  (if  any) 
between  pairs  of  PERSONS.  */ 

call  PROMPT_AND_READ(); 
READ_AND_PROCE  S  S_REQUE  ST : 

do  while  (REQUESTJBUFFER  ~=  REQUEST_TO_STOP) ; 

/*  The  following  code  retrieves  and  validates  a  user  request 

for  the  RELATIONSHIP  between  two  identified  PERSONS.  */ 
call  CHECK_REQUEST  (ERROR_MESSAGE,   SEMICOLON_LOCATION) ; 

/*  Syntax  check  of  request  completed.     Now  either  display  error 
message  or  search  for  the  two  PERSONS.  */ 

if  ERROR_MESSAGE  =  REQUEST_OK  then 

do;       /*  Request  syntactically  correct  - 

search  for  requested  PERSONS.  */ 
call  BUFFER_TO_PERSON  ( PERSON 1_I DENT,   1,   SEMICOLON_LOCATION  -  1); 
call  BUFFER_TO_PERSON  (PERS0N2_IDENT ,   SEMICOLON_LOCATION  +  1, 

length  (REQUEST_BUFFER)); 
call  SEARCH_FOR_REQUESTED_PERSONS  (PERS0N1_IDENT,   PERS0N2_IDENT , 

PERSON  1_INDEX,  PERS0N2_INDEX, 
PERS0N1_F0UND,  PERS0N2_F0UND); 
if  (PERS0N1_F0UND  =  1)  &  (PERS0N2_F0UND  =  1)  then 
/*  Exactly  one  match  for  each  PERSON  -  proceed  to 

determine  RELATIONSHIP,   if  any.  */ 
if  PERS0N1_INDEX  =  PERS0N2_INDEX  then 

if  PERSON  (PERS0N1_INDEX)   .   GENDER  =  MALE  then 

put  skip  list  ('   '   II  PERSON  (PERS0N1_INDEX)   .  NAME  || 
'  is  identical  to  himself.'); 

else 

put  skip  list  ('   '   II  PERSON  (PERSON 1_INDEX)   .  NAME  || 
'  is  identical  to  herself.'); 

else 

call  FIND_RELATIONSHIP  (PERS0N1_INDEX,   PERSON 2_INDE X) ; • 
else      /*  either  not  found  or  more  than  one  found  */ 
do ; 

if  PERS0N1_F0UND  =  0  then 

put  skip  list  ('  First  person  not  found.'); 
else 

if  PERSON 1_F0UND  >  1  then 

put  skip  list  ('  Duplicate  names  for  first  person  -  use'   I  I 
'  numeric  identifier.'); 
if  PERS0N2_F0UND  =  0  then 

put  skip  list  ('  Second  person  not  found.'); 
else 

if  PERS0N2_F0UND  >  1  then 

put  skip  list  ('  Duplicate  names  for  second  person  -  use'    I  I 
'  numeric  identifier.'); 

end; 

end;       /*  processing  of  syntactically  legal  request  */ 
else 

put  skip  list  ('  Incorrect  request  format:  '   II  ERROR_MESSAGE ) ; 
call  PROMPT_AND_READ  (  )  ; 
end  READ_AND_PROCESS_REQUEST; 
put  skip  list  ('  End  of  relation-finder.'); 
/*  End  execution  of  main  sequence  RELATE 
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procedures  under  RELATE  begin  here  */ 


LINK  RELATIVES:  procedure  (FROM_INDEX,  RELATIONSHIP,  TO_INDEX); 


/*  begin  execution  of  LINK_RELATIVES  */ 

if  RELATIONSHIP  =  SPOUSE_IDENT  then 
do ; 

call  LINK_ONE_WAY  (FROM_INDEX,  SPOUSE,  TO_INDEX); 
call  LINK_ONE_WAY  (TO_INDEX,  SPOUSE,  FROM_INDEX); 
end; 

else     /*  RELATIONSHIP  is  mother  or  father  */ 
do ; 

call  LINK_ONE_WAY  (FROM_INDEX,   PARENT,  TO_INDEX); 
call  LINK_ONE_WAY  (TO_INDEX,  CHILD,  FROM_INDEX); 
end; 

LINK  ONE  WAY:  procedure  (FROM  INDEX,  THIS  EDGE,  TO  INDEX); 


FROM_INDEX    fixed  binary  (10,0), 
THIS_EDGE      fixed  binary  (4,0), 
TO_INDEX        fixed  binary  (10,0); 

declare 

NEW_NEIGHBOR  pointer; 

/*  begin  execution  of  LINK_ONE_WAY  */ 

allocate  NEIGHBOR_RECORD  set  (NEW_NEIGHBOR) ; 
NEW_NEIGHBOR  ->  NEIGHBOR_INDEX  =  TO_INDEX; 
NEW_NEIGHBOR  ->  NEIGHBOR_EDGE     =  THIS_EDGE ; 
NEW_NEIGHBOR  ->  NEXT_NEIGHBOR  = 

PERSON  (FROM_INDEX)   .  NEIGHBOR_LIST_HEADER; 
PERSON  (FROM_INDEX)   .  NEIGHBOR_LIST_HEADER  =  NEW_NEIGHBOR; 
end  LINK_ONE_WAY; 

end  LINK_RELATIVES ; 

PROMPT_AND_READ:  procedure; 

/*  Issues  prompt  for  user-request,  reads  in  request, 

blank-fills  buffer,  and  skips  to  next  line  of  input.  */ 


declare 

FROM_INDEX 
RELATIONSHIP 
TO  INDEX 


fixed  binary  (10,0), 
fixed  binary  (4,0), 
fixed  binary  (10,0); 


declare 


declare    BUFFER_INDEX  fixed  binary  (10,0), 

SEMICOLON  COUNT      fixed  binary  (4,0); 


/*  begin  execution  of  PROMPT_AND_READ  */ 

put  skip  (2)  list  ('   ') 

put  skip  list  ('  Enter  two  person-identifiers  (name  or  number),'); 
put  skip  list  ('  separated  by  semicolon.  Enter  "stop"  to  stop.'); 
put  skip  list  ('  '); 

/*    The  use  of  sysin  for  record-oriented,  rather  than  stream-oriented, 
input  may  not  be  considered  to  be  standard  usage.     It  is  done  here 
because  stream  input  cannot  recognize  line  boundaries,  so  as  to 
read  an  entire  line  from  the  terminal.  */ 
read  file  (sysin)  into  (REQUESTJBUFFER); 

end  PROMPT_AND_READ; 

CHECK_REQUEST:  procedure  (REQUESTJSTATUS ,   SEMICOLON_LOCATION) ; 
/*  Performs  syntactic  check  on  request  in  buffer.  */ 

declare 

REQUEST_STATUS  character  (40), 

SEMICOLONJLOCATION  fixed  binary  (10,0); 

/*  begin  execution  of  CHECKREQUEST  */ 

SEMICOLON_LOCATION  =  index  (REQUESTJBUFFER,  ';'); 
if  SEMICOLON_LOCATION  =  0  | 

index  (substr  (REQUEST_BUFFER,   SEMICOLON_LOCATION  +  1),  ';')  >  0 
then 

REQUEST_STATUS  =  'must  be  exactly  one  semicolon.'; 
else 

if  before  (REQUESTJBUFFER,  ';')  =  '  '  then 

REQUEST_STATUS  =  'null  field  preceding  semicolon.'; 
else 

if  after  (REQUEST_BUFFER,   ';')  =  '  '  then 

REQUEST  STATUS  =  'null  field  following  semicolon.'; 
else 

REQUEST_STATUS  =  REQUESTJ)K; 
end  CHECK_RE QUEST; 

BUFFERjr0_PERS0N:   procedure  (PERSON_ID,   STARTJLOCATION,   STOPJ.OCATION) ; 
/*  fTlls  in  the  PERSON_ID  from  the  designated  portion 
of  the  REQUEST_BUFFER.  */ 

declare 

PERSON_ID        character  (20), 
(START_L0CATI0N,  STOPJLOCATION) 

fixed  binary  (10,0); 

declare 

FIRSTJION_BLANK  fixed  binary  (10,0); 

/*  begin  execution  of  BUFFER_T0_PERS0N  */ 

do  FIRST_NONJBLANK  =  STARTJLOCATION  to  ST0PJ.0CATI0N 

while  (substr  (REQUEST_BUFFER,  FIRST_NON_BLANK,   1)  =  '  '); 
end; 

PERSON  ID  =  substr  (REQUESTJBUFFER,  FIRSTJ^ON_BLANK, 

STOP_LOCATION  -  FIRST_NON_BLANK  +1); 

end  BUFFER  TO  PERSON; 
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SEARCH_FOR_REQUESTED_PERSONS:  procedure  (PERS0N1_IDENT,  PERS0N2_IDENT, 

PERS0N1_INDEX,  PERS0N2_INDEX, 
PERS0N1_F0UND,   PERS0N2_F0UND) ; 
/*  SEARCH_FOR_REQUESTED_PERSONS  scans  through  the  PERSON  array, 
looking  for  the  two  requested  PERSONS.     Match  may  be  by  NAME 
or  unique  IDENTIFIER-number .  */ 
declare 

(PERS0N1_IDENT,  PERS0N2_IDENT)  character  (20), 
(PERS0N1_INDEX,   PERS0N2_INDEX)  fixed  binary  (10,0), 
(PERS0N1_F0UND,  PERS0N2_F0UND)  fixed  binary  (10,0); 
declare 

THIS_IDENT  character  (20), 

CURRENT  fixed  binary  (10,0); 

/*  begin  execution  of  SEARCH_FOR_REQUESTED_PERSONS  */ 
PERSON 1_F0UND  =0; 
PERS0N2_F0UND  =  0; 
SCAN_ALL_PERSONS : 

do  CURRENT     =  1  to  NUMBER_OF_PERSONS ; 

/*  THIS_IDENT  contains  CURRENT  PERSON'S  numeric  IDENTIFIER 

left- justified ,  padded  with  blanks.  */ 
THIS_IDENT  =  PERSON  (CURRENT)   .  IDENTIFIER; 
/*  allow  identification  by  name  or  number.  */ 
if  (PERS0N1_IDENT  =  THIS_IDENT)  | 

(PERS0N1_IDENT  =  PERSON  (CURRENT)   .  NAME) 
then 
do ; 

PERS0N1_F0UND  =  PERS0N1_F0UND  +  1; 

PERS0N1_INDEX  =  CURRENT; 

end; 

if  (PERS0N2_IDENT  =  THIS_IDENT)  | 

(PERS0N2_IDENT  =  PERSON  (CURRENT)   .  NAME) 
then 

do ; 

PERS0N2_F0UND  =  PERS0N2_F0UND  +  1; 

PERS0N2_INDEX  =  CURRENT; 

end; 

end  SCAN_ALL_PERSONS ; 
end  SEARCH_FOR_REQUESTED_PERSONS; 

/*  End  of  utility  procedures  under  RELATE. 


FIND_RELATIONSHIP  does  major  work  of  program:  determines 
relationship  between  any  two  people  In  PERSON  array.  */ 


FIND_RELATIONSHIP:   procedure  (TARGET_INDEX,  SOURCE_INDEX) ; 
/*  Finds  shortest  path  (if  any)  between  two  PERSONS  and 

determines  their  RELATIONSHIP  based  on  Immediate  relations 
traversed  In  path.     PERSON  array  simulates  a  directed  graph, 
and  algorithm  finds  shortest  path,  based  on  following 
weights:  PARENT -CHILD  edge  =1.0 

SPOUSE -SPOUSE  edge  =1.8  */ 

declare 

( TARGE T_INDEX,   SOURCE_INDEX)  fixed  binary  (10,0); 
declare 

SEARCH_STATUS  character  (1), 

/*  values  for  SEARCH_STATUS  */ 
(SEARCHING  Initial  ('?'), 

SUCCEEDED  initial  ('!'), 

FAILED  initial  ('X'))  character  (1), 

(PERSON_INDEX,   THIS_NODE,  AD JACENT_NODE ,  BEST_NEARBY_INDEX, 
LAST_NEARBY_INDEX)  fixed  binary  (10,0), 

NEARBY_NODE  dimension  (1:300)  fixed  binary  (10,0), 

THIS_EDGE  fixed  binary  (4,0), 

THIS_NEIGHBOR       .  pointer , 

RELATIONSHIP  fixed  binary  (4,0), 

MINIMAL_DI STANCE  float  decimal  (6); 

/*    begin  execution  of  FIND_RELATIONSHIP  */ 
/*  initialize  PERSON-array  for  processing  - 

mark  all  nodes  as  not  seen  */ 
PERSON  .  REACHED_STATUS  =  NOT_SEEN; 
/*  mark  source  node  as  REACHED  */ 
THIS_NODE  =  SOURCE_INDEX; 

PERSON  (THIS_NODE)   .  REACHED_STATUS  =  REACHED; 

PERSON  (THIS_NODE)   .  DISTANCE_FROM_SOURCE  =0.0; 

/*  no  NEARBY  nodes  exist  yet  */ 

LAST_NEARBY_INDEX  =  0; 

if  THISJNODE  =  TARGET_INDEX  then 

SEARCH_STATUS  =  SUCCEEDED; 
else 

SEARCH  STATUS  =  SEARCHING; 
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/*  Loop  keeps  processing  closest-to-source ,  unREACHED  node 
until  target  REACHED,  or  no  more  connected  nodes.  */ 
SEARCH_FOR_TARGET : 

do  while  (SEARCH_STATUS  =  SEARCHING); 

/*  Process  all  nodes  adjacent  to  THIS_NODE  */ 
THIS_NEIGHBOR  =  PERSON  (THIS_NODE)   .  NEIGHBOR_LIST_HEADER; 
do  while  (THIS_NEIGHBOR  ~=  null()); 

call  PROCESS_ADJACENT_NODE  (THISJJODE, 

THISJNEIGHBOR  ->  NEIGHBOR_INDEX, 
THIS_NEIGHBOR  ->  NEIGHBOR_EDGE ) ; 
THIS_NEIGHBOR  =  THIS_NEIGHBOR  ->  NEXT_NEIGHBOR; 
end; 

/*  All  nodes  adjacent  to  THIS_NODE  are  set.     Now  search  for 

shortest-distance  unREACHED  (but  NEARBY)  node  to  process  next.  */ 
if  LAST_NEARBY_INDEX  =  0  then 

SEARCH_STATUS  =  FAILED; 
else 

do ; 

MINIMAL_DISTANCE  =  l.Oe+18; 

do  PERSON_INDEX  =  1  to  LAST_NEARBY_INDEX; 

if  PERSON  (NEARBY_NODE   (PERSON_INDEX) )   .  DISTANCE_FROM_SOURCE 
<  MINIMAL_DISTANCE  then 

do; 

BEST_NEARBY_INDEX  =  PERSON_INDEX; 
MINIMAL_DI  STANCE  = 

PERSON  (NEARBY_NODE  (PERSON_INDEX) )   .  DISTANCE_FROM_SOURCE ; 

end; 

end;     /*  PERSON_INDEX  loop  */ 

/*  establish  new  THIS_NODE  */ 

THIS_NODE  =  NEARBY_NODE  (BEST_NEARBY_INDEX) ; 

/*  change  THIS_NODE  from  being  NEARBY  to  REACHED  */ 

PERSON  (THIS_NODE)   .  REACHED_STATUS  =  REACHED; 

/*  remove  THIS_NODE  from  NEARBY  list  */ 

NEARBY_NODE  (BEST_NEARBY_INDEX)  =  NEARBYJJODE  (LAST_NEARBY_INDEX) ; 
LAST_NEARBY_INDEX  =  LAST_NEARBY_INDEX  -  1; 
if  THIS_NODE  =  TARGET_INDEX  then 

SEARCH_STATUS  =  SUCCEEDED; 
end;       /*  determination  of  next  node  to  process  */ 
end  SEARCH_FOR_TARGET; 

/*  Shortest  path  between  PERSONS  now  established.     Next  task  is 
to  translate  path  to  English  description  of  RELATIONSHIP.  */ 

if  SEARCH_STATUS  =  FAILED  then 

put  skip  list  C        PERSON  (TARGET_INDEX)  .  NAME,  '  is  not  related  to 
PERSON  (SOURCE_INDEX)   .  NAME); 
else      /*  success  -  parse  path  to  find  and  display  RELATIONSHIP  */ 

do ; 

call  RESOLVE_PATH_TO_ENGLISH; 

call  COMPUTE_COMMON_GENES   ( SOURCE_INDEX,  TARGET_INDEX) ; 
end; 


/*  End  execution  of  FIND  RELATIONSHIP. 
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Utility  procedures  begin  here.  */ 

PROCESS_ADJACENT_NODE:  procedure  (BASE_NODE,  NEXT_NODE ,  NEXT_BASE_EDGE ) ; 
/*  NEXT_NODE  is  adjacent  to  last-REACHED  node  (=  BASE_NODE). 
if  NEXT_NODE  already  REACHED,  do  nothing.  ~ 
If  previously  seen,  check  whether  path  thru  BASE_NODE  is 
shorter  than  current  path  to  NEXT_NODE,  and  if  so  re-link 
next  to  base . 

If  not  previously  seen,  link  next  to  base  node.  */ 
declare 

(BASE_NODE,  NEXT_NODE )  fixed  binary  (10,0), 
NEXT_BASE_EDGE  fixed  binary  (4,0); 

declare 

(WEIGHT_THIS_EDGE ,  DISTANCE_THRU_BASE_NODE ) 

float  decimal  (6); 

/*  begin  execution  of  PROCESS_ADJACENT  NODE  */ 

if  PERSON  (NEXT_NODE)   .  REACHED_STATUS  ~=  REACHED  then 
do ; 

if  NEXT_BASE_EDGE  =  SPOUSE  then 

WEIGHT_THIS_EDGE  =  1.8; 
else 

WEIGHTJIHISJEDGE  =  1.0; 
DISTANCE_THRU_BASE_NODE  =  WEIGHT_THIS_EDGE  + 

PERSON  (BASEJJODE)   .  DISTANCE_FROM_SOaRCE ; 
if  PERSON  (NEXT_NODE)   .  REACHED_STATUS  =  NOT_SEEN  then 

do ; 

PERSON  (NEXTJIODE)   .  REACHED_STATUS  =  NEARBY; 
LAST_NEARBY_INDEX  =  LAST_NEARBY_INDEX  +  1; 
NEARBY_NODE  (LAST_NEARBY_INDEX)  =  NEXT_NODE ; 
call  LINK_NEXT_NODE_TO_BASE_NODE ; 
end; 

else       /*  REACHED_STATUS  =  NEARBY  */ 
if  DISTANCE_THRU_BASE_NODE  < 

PERSON  (NEXT_NODE)   .  DISTANCE_FROM_SOURCE  then 
call  LINK_NEXT_NODE_TO_BASE_NODE ; 
end;       /*  if  REACHED_STATUS  not  =  REACHED  */ 

LINK_NEXT_NODE_TO_BASE_NODE :  procedure ; 
/*  link  next  to  base  by  re-setting  its  predecessor  index  to 
point  to  base,  note  type  of  edge,  and  re-set  distance 
as  it  is  through  base  node.  */ 
/*  begin  execution  of  LINK_NEXr_NODE_TO_BASE_NODE  */ 

PERSON  (NEXT_NODE)  .  DISTANCE_FROM_SOURCE  =  DISTANCE_THRU_BASE_NODE ; 
PERSON  (NEXT_NODE)   .  PATH_PREDECESSOR  =  BASE_NODE ; 

PERSON  (NEXT_NODE)   .  EDGE_TO_PREDECESSOR    =  NEXT_BASE_EDGE ; 
end  LINK_NEXT_NODE_TO_BASE_NODE; 

end  PROCESS_ADJACENT_NODE ; 

/*  End  utility  procedures  under  FIND_RELATIONSHIP. 
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Begin  two  major  procedures:  RESOLVE_PATH_TO_ENGLISH  and 
COMPUTE_COMMON_GENES  */ 

RESOLVE_PATH_TO_ENGLISH:  procedure ; 

/*  RESOLVE_PATH_TO_ENGLISH  condenses  the  shortest  path  to  a 
series  of  RELATIONSHIPS  for  which  there  are  English 
descriptions.  */ 

/*  Key  persons  are  the  ones  in  the  RELATIONSHIP  path  which  remain 
after  the  path  is  condensed.  */ 


declare 

/*  values  for  sibling  proximity 

(STEP 

initial  ('S'), 

HALF 

initial  ('H'), 

FULL 

initial  ('F')) 

character 

(1); 

declare 

01  KEY 

PERSON  dimension 

(1:300), 

05  ' 

PERSON  INDEX 

fixed 

binary  (10,0), 

05 

GENERATION_GAP 

fixed 

binary  (10,0), 

05 

PROXIMITY 

character  (1), 

05 

RELATION  TO  NEXT 

fixed 

binary  (4,0), 

05 

COUSIN  RANK 

fixed 

binary  (10,0); 

declare 

/*  these  variables  are  used  to  condense  the  path  */ 
(KEY_RELATION,  LATER_KEY_RELATION,  PRIMARY_RELATION, 
NEXT_PRIMARY_RELATION)  fixed  binary  (4,0), 

GENERATION_COUNT  fixed  binary  (10,0), 

(KEY_INDEX,  LATER_KEY_INDEX,  PRIMARY_INDEX) 

fixed  binary  (10,0), 
ANOTHER_ELEMENT_POSSIBLE        bit  (1); 

/*  begin  execution  of  RESOLVE_PATH_TO_ENGLISH  */ 

put  skip  list  ('  Shortest  path  between  identified  persons:  '); 
THIS_NODE     =  TARGET_INDEX; 

/*  Display  path  and  initialize  KEY_PERSON  array  from  path  elements 
TRAVERSE_SHORTEST_PATH : 

do  KEY_INDEX  =  1  to  300  while  (THIS_NODE  ~=  SOURCE_INDEX) ; 
begin; 
declare 

EDGE_TYPE  dimension  (1:3)  character  (9)  static 

initial  ('parent  of,  'child  of,  'spouse  of); 
put  skip  list  ('  '   II  PERSON  (THIS_NODE)   .  NAME   ||    '  is  '  || 
EDGE_TYPE  (PERSON  (THIS_NODE)   .  EDGE_TO_PREDECESSOR) ) ; 

end; 

KEY_PERSON  (KEY_INDEX)   .  PERSON_INDEX  =  THIS_NODE ; 

KEY_PERSON  (KEY_INDEX)   .   RELATION_TO_NEXT  = 

PERSON  (THIS_NODE)   .  EDGE_TO_PREDECESSOR; 
if  PERSON  (THIS_NODE)   .  EDGE_TO_PREDECESSOR  =  SPOUSE  then 

KEY_PERSON  (KEY_INDEX)   .  GENERATIONjSAP  =  0; 
else 

KEY_PERSON  (KEY_INDEX)   .  GENERATIONjSAP  =  1; 
THIS_NODE  =  PERSON  (THIS_NODE)   .  PATH_PREDECESSOR; 
end  TRAVERSE_SHORTEST_PATH; 

put  skip  listC  '    II   PERSON  (THIS_NODE)   .  NAME); 
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KEY_PERSON  (KEY_INDEX)  .   PERSON_INDEX  =  THIS_NODE ; 

KEY_PERSON  (KEY_INDEX)  .  RELATION_TO_NEXT  =  NULL  RELATION; 

KEY_PERSON  (KEY_INDEX  +  1)    .   RELATION_TO_NEXT  =  NULL_RELATION; 
/*  Resolve  CHILD-PARENT  and  CHILD-SPOUSE-PARENT  relations 
to  SIBLING  relations.  */ 
FIND_SIBLINGS: 

do  KEY_INDEX  =  1  to  300 

while  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  ~=  NULL_RELATION) ; 
if  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  CHILD  then 
do ; 

LATER_KEY_RELATION  =  KEY_PERSON  (KEY_INDEX  +  1)  .  RELATION_TO_NEXT ; 
if  LATER_KEY_RELATION  =  PARENT  then 

/*  found  either  full  or  half  SIBLINGS  */ 

do ; 

KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  SIBLING; 
if  FULL_SIBLING  (KEY_PERSON  (KEY_INDEX)  .  PERSON_INDEX, 

KEY_PERSON  (KEY_INDEX  +  2)   .  PERSON_INDEX) 

then 

KEY_PERSON  (KEY_INDEX)   .  PROXIMITY  =  FULL; 
else 

KEY_PERSON  (KEY_INDEX)   .   PROXIMITY  =  HALF; 
call  CONDENSE_KEY_PERSONS   (KEY_INDEX,  1); 
end;       /*  processing  of  full/half  SIBLINGS  */ 
else 

if  (LATER_KEY_RELATION  =  SPOUSE)  & 

(KEY_PERSON  (KEY_INDEX  +  2)   .  RELATION_TO_NEXT  =  PARENT) 
then     /*  found  step-SIBLINGs  */ 

do ; 

KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  SIBLING; 
KEY_PERSON  (KEY_INDEX)   .   PROXIMITY  =  STEP; 

call  CONDENSE_KEY_PERSONS  (KEY_INDEX,  2); 
end;       /*  processing  of  step-SIBLINGs  */ 
end;       /*  if  RELATION_TO_NEXr  =  CHILD  */ 
end  FIND_SIBLINGS; 

/*  Resolve  CHILD-CHILD-...  and  PARE NT -PARE NT -.. .  relations  to 
direct  descendant  or  ancestor  relations.  */ 
FIND_ANCESTORS_OR_DESCENDANTS : 
do  KEY_INDEX  =  1  to  300 

while  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  ~=  NULL_RELATION) ; 
if  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  CHILD)  | 
(KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXr  =  PARENT) 
then 
do ; 

do  LATER_KEY_INDEX  =  KEY_INDEX  +  1  to  300 

while  (KEY_PERSON  (LATER_KEY_INDEX)   .  RELATION_TO_NEXT  = 
KEYJPERSON  (KEY_INDEX)   .  RELATION_TO_NEXT ) ; 

end; 

GENERATIONJCOUNT  =  LATER_KEY_INDEX  -  KEY_INDEX; 
If  GENERATION_COUNT  >  1  then 

do;     /*  compress  generations  */ 

KEY_PERSON  (KEY_INDEX)   .   GENERATION_GAP  =  GENERATIONJCOUNT ; 
call  CONDENSE_KEY_PERSONS  (KEY_INDEX,   GENERATION_COUNT  -  1); 
end; 

end;       /*  if  RELATIONJTOJJEXT  =  CHILD  or  PARENT  */ 
end  FIND  ANCESTORS  OR  DESCENDANTS; 
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/*  Resolve  CHILD-SIBLING-PARENT  to  COUSIN, 
CHILD-SIBLING  to  NEPHEW, 

SIBLING-PARENT  to  UNCLE.  */ 

FIND_COUSINS_NEPHEWS_UNCLES : 
do  KEY_INDEX  =  1  to  300 

while  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  ~=  NULL_RELATION) ; 
LATER_KEY_RELATION  =  KEY_PERSON  (KEY_INDEX  +  1)   .  RELATION_TO_NEXT ; 
if  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  CHILD)  & 

(LATER_KEY_RELATION  =  SIBLING) 
then      /*  COUSIN  or  NEPHEW  */ 

If  KEY_PERSON  (KEY_INDEX  +  2)   .  RELATION_TO_NEXT  =  PARENT  then 
/*  found  COUSIN  */ 
do ; 

KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  COUSIN; 
KEY_PERSON  (KEY_INDEX)   .   PROXIMITY  = 

KEYJPERSON  (KEY_INDEX  +  1)   .  PROXIMITY; 
KEY_PERSON  (KEY_INDEX)   .  COUSIN_RANK  = 

min  (KEY_PERSON  (KEY_INDEX)  .  GENERATION_GAP, 

KEY_PERSON  (KEY_INDEX  +  2)   .  GENERATION_GAP ) ; 
KEY_PERSON  (KEY_INDEX)   .  GENERATION_GAP  = 

abs  (KEY_PERSON  (KEY_INDEX)  .   GENERATION_GAP  - 

KEYJPERSON  (KEY_INDEX  +  2)   .  GENERATION_GAP) ; 
call  CONDENSE_KEY_PERSONS  (KEY_INDEX,  2); 
end; 

else     /*  found  NEPHEW  */ 
do; 

KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  NEPHEW; 
KEY_PERSON  (KEY_INDEX)   .   PROXIMITY  = 

KEY_PERSON  (KEY_INDEX  +  1)   .  PROXIMITY; 
call  CONDENSE_KEY_PERSONS  (KEY_INDEX,  1); 
end; 

else      /*  not  COUSIN  or  NEPHEW  */ 

if  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  SIBLING)  & 

(LATER_KEY_RELATION  =  PARENT) 
then      /*  found  UNCLE  */ 
do ; 

KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  =  UNCLE; 
KEY_PERSON  (KEY_INDEX)   .   GENERATION_GAP  = 

KEY_PERSON  (KEY_INDEX  +  1)   .  GENERATION_GAP; 
call  CONDENSE_KEY_PERSONS  (KEY_INDEX,  1); 
end; 

end  FIND  COUSINS  NEPHEWS  UNCLES; 
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/*  Loop  below  will  pick  out  valid  adjacent  strings  of  elements 
to  be  displayed.     KEY_1NDEX  points  to  first  element, 
LATER_KEY_INDEX  to  last  element,  and  PRIMARY_INDEX  to  the 
element  which  determines  the  primary  English  word  to  be  used. 
Associativity  of  adjacent  elements  in  condensed  table 
is  based  on  English  usage.  */ 

KEY_INDEX  =  1; 

put  skip  list  ('  Condensed  path:'); 
CONSOLIDATE_ADJACENT_PERSONS : 

do  while  (KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT  ~=  NULL_RELATION) ; 

KEY_RELATION        =  KEY_PERSON  (KEY_INDEX)   .  RELATION_TO_NEXT ; 

LATER_KEY_INDEX  =  KEY_INDEX; 

PRIMARY_INDEX      =  KEY_1NDEX; 

if  KEY_PERSON  (KEY_INDEX  +  1)   .  RELATION_TO_NEXT  ~=  NULL_RELATION  then 
do;       /*  seek  multi-element  combination  */ 
AN0THER_ELEMENT_P0SS1BLE  =  TRUE; 
if  KEY_RELATION  =  SPOUSE  then 
do ; 

LATER_KEY_INDEX  =  LATER_KEY_INDEX  +  1; 
PRIMARY_INDEX      =  LATER_KEY_INDEX; 

if  (KEYJPERSON  (LATER_KEY_INDEX)   .  RELATION_TO_NEXT  =  SIBLING)  | 
(KEY_PERSON  (LATER_KEY_INDEX)   .  RELATION_TO_NEXT  =  COUSIN) 

then      /*  Nothing  can  follow  SPOUSE-SIBLING  or  SPOUSE -COUSIN  */ 
ANOTHER_ELEMENT_POSSIBLE  =  FALSE; 

end; 

/*  PRIMARY_INDEX  is  now  correctly  set.     Next  if-statement 
determines  if  a  following  SPOUSE  relation  should  be 
appended  to  this  combination  or  left  for  the  next 
combination.  */ 
if  ANOTHER_ELEMENT_POSSIBLE  & 

(KEY_PERSON  (PRIMARY_INDEX  +  I)   .  RELATION_TO_NEXT  =  SPOUSE) 
/*  Only  a  SPOUSE  can  follow  a  Primary  */ 
then 

do;     /*  check  primary  preceding  and  following  SPOUSE.  */ 
PRIMARY_RELATION 

KEY_PERSON  (PRIMARY_INDEX)   .  RELATION_TO_NEXT ; 
NEXT_PRIMARY_RELATION  = 

KEY_PERSON  (PRIMARY_INDEX  +  2)   .  RELATION_TO_NEXT ; 
if  (NEXT_PRIMARY_RELATION  =  NEPHEW  | 
NEXT_PRIMARY_RELATION  =  COUSIN  | 
NEXT_PRIMARY_RELATION  =  NULL_RELATION ) 
I   (PRIMARY_RELATION  =  NEPHEW) 
I   (   (  PRIMARY_RELATION  =  SIBLING  I 
PRIMARY_RELATION  =  PARENT) 
&  (NEXT_PRIMARY_RELATION  ~=  UNCLE  )  ) 
then    /*  append  following  SPOUSE  with  this  combination.  */ 

LATER_KEY_INDEX  =  LATER_KEY_INDEX  +  1; 
end;     /*  check  primary  preceding  and  following  SPOUSE  */ 
end;     /*  multi-element  combination  */ 
call  DISPLAY_RELATION  (KEY_INDEX,  LATER_KEY_INDEX,  PRIMARY_INDEX) ; 
KEY_INDEX  =  LATER_KEY_INDEX  +  1; 
end  CONSOLIDATE_ADJACENT_PERSONS ; 

put  skip  list  ('  '  II  PERSON  (KEY_PERSON  (KEY_INDEX)  .  PERSON_INDEX)  .  NAME); 
/*  End  execution  of  RESOLVE  PATH_TO_ENGLISH. 
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Begin  utility  procedures  for  RESOLVE_PATH_TO_ENGLISH.  */ 

FULL_SIBLING:   procedure  (INDEXl,  INDEX2) 
returns  (bit(l)); 
/*  Determines  whether  two  PERSONS  are  full  siblings,  i.e., 
have  the  same  two  parents .  */ 

declare 

(INDEXl,   INDEX2)  fixed  binary  (10,0); 
return 

((PERSON  (INDEXl)  .  RELATIVE_IDENTIFIER  (FATHER_IDENT)  ~=  NULL_IDENT)  & 
(PERSON  (INDEXl)  .  RELATIVE_IDENTIFIER  (MOTHER_IDENT)  ~=  NULL_IDENT)  & 
(PERSON  (INDEXl)   .  RELATIVE_IDENTIFIER  (FATHER_IDENT)  = 

PERSON  (INDEX2)   .  RELATIVE_IDENTIFIER  ( FATHER_IDENT)  )  & 
(PERSON  (INDEXl)   .  RELATIVE_IDENTIFIER  (MOTHER_IDENT)  = 

PERSON  (INDEX2)   .  RELATIVE_IDENTIFIER  (MOTHER_IDENT)  )  ); 
end  FULL_SIBLING; 

CONDENSE_KEY_PERSONS:  procedure  (AT_INDEX,  GAP_SIZE); 

/*  CONDENSE_KEY_PERSONS  condenses  superfluous  entries  from  the 

KEY_PERSON  array,  starting  at  AT_INDEX.  */ 
declare 

AT_INDEX  fixed  binary  (10,0), 
GAP_SIZE  fixed  binary  (10,0); 
declare 

(RECEIVE_INDEX,  SENDJLNDEX)  fixed  binary  (10,0); 
/*  begin  execution  of  CONDENSE_KEY_PERSONS  */ 
RECEIVE_INDEX  =  AT_INDEX  +  1; 
SEND_INDEX        =  RECEIVE_INDEX  +  GAP_SIZE; 
KEY_PERSON  (RECEIVE_INDEX)  =  KEY_PERSON  (SEND_INDEX) ; 

do  while  (KEY_PERSON  (SEND_INDEX)   .  RELATION_TO_NEXT  ~=  NULL_RELATION) ; 

RECEIVE_INDEX  =  RECEIVE_INDEX  +  1; 

SEND_INDEX        =  RECEIVE_INDEX  +  GAP_SIZE; 

KEY_PERSON  (RECEIVE_INDEX)  =  KEY_PERSON  (SEND_INDEX) ; 
end; 

end  CONDENSE  KEY  PERSONS; 


*  End  utility  procedures. 


Begin  DISPLAY_RELATION,  which  does  major  work  of  displaying 
under  RESOLVE_PATH_TO_ENGLISH.  */ 

DISPLAY_RELATION:   procedure  (FIRST_INDEX,  LAST_INDEX,   PRIMARY_INDEX) ; 
/*  DISPLAY_RELATION  takes  1,   2,  or  3  adjacent  elements  in  the 
condensed  table  and  generates  the  English  description  of 
the  relation  between  the  first  and  last  +  1  elements.  */ 
declare 

(FIRST_INDEX,  LAST_INDEX,  PRIMARY_INDEX)  fixed  binary  (10,0); 
declare 

DISPLAYJBUFFER        character  (80)  varying, 
INLAW  bit  (1), 

THIS_PROXIMITY  character  (1), 
THIS_GENDER  character  (1), 

SUFFIX_INDICATOR    fixed  binary  (6,0), 
(FIRST_RELATION,  LAST_RELATI0N,  PRIMARY_RELATION) 

fixed  binary  (4,0), 
(THIS_GENERATION_GAP,  THIS_COUSIN_RANK) 

fixed  binary  (10,0); 

/*    begin  execution  of  DISPLAY_RELATION  */ 

FIRST_RELATION  =  KEY_PERS0N  (FIRST_INDEX)  .  RELATI0N_T0_NEXT ; 
LAST_RELATI0N  =  KEY_PERS0N  (LAST_INDEX)         .  RELATI0N_T0_NEXT ; 

PRIMARYJRELATION     =  KEY_PERS0N  (PRIMARY_INDEX)   .  RELATI0N_T0_NEXT ; 
/*  set  THIS_PROXIMITY  */ 

if  ((PRIMARY_RELATION  =  PARENT)  &  (FIRST_RELATION  =  SPOUSE))  | 

((PRIMARY_RELATION  =  CHILD)  &  (LAST_RELATION    =  SPOUSE)) 
then 

THIS_PROXIMITY  =  STEP;  • 
else 

if  PRIMARY_RELATION  =  SIBLING  | 

PRIMARY_RELATION  =  UNCLE  | 

PRIMARY_RELATION  =  NEPHEW  | 

PRIMARY_RELATION  =  COUSIN 
then 

THIS_PROXIMITY  =  KEY_PERSON  (PRIMARY_INDEX)   .  PROXIMITY; 
else 

THIS_PROXIMITY  =  FULL; 
/*  set  THIS_GENERATION_GAP  */ 
if  PRIMARY_RELATION  =  PARENT  | 

PRIMARY_RELATION  =  CHILD  | 

PRIMARY_RELATION  =  UNCLE  | 

PRIMARY_RELATION  =  NEPHEW  | 

PRIMARY_RELATION  =  COUSIN 
then 

THIS_GENERATION_GAP  =  KEYJPERSON  (PRIMARY_INDEX)   .  GENERATION_GAP 
else 

THIS  GENERATION  GAP  =  0; 
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/*  set  INLAW  */ 
INLAW  =  FALSE; 

if  (FIRST_RELATION  =  SPOUSE)  & 
(PRIMARY_RELATION  =  SIBLING  I 
PRIMARY_RELATION  =  CHILD  I 
PRIMARY_RELATION  =  NEPHEW  | 
PRIMARY_RELATION  =  COUSIN) 

then 

INLAW  =  TRUE; 
if  (LAST_RELATION  =  SPOUSE)  & 
(PRIMARY_RELATION  =  SIBLING  | 
PRIMARY_RELATION  =  PARENT  | 
PRIMARY_RELATION  =  UNCLE  | 
PRIMARY_RELATION  =  COUSIN) 

then 

INLAW  =  TRUE; 
/*  set  THIS_COUSIN_RANK  */ 
If  PRIMARY_RELATION  =  COUSIN  then 

THIS_COUSIN_RANK  =  KEY_PERSON  (PRIMARY_INDEX)   .  COUSIN_RANK; 
else 

THIS_COUSIN_RANK  =  0; 
/*  parameters  are  set  -  now  generate  display.  */ 
DISPLAY  BUFFER  = 

'  '  Tl  PERSON  (KEY_PERSON  (FIRST_INDEX)  .  PERSON_INDEX)  .  NAME  ||  '  is  '; 
if  PRIMARY_RELATION  =  PARENT  | 

PRIMARY_RELATION  =  CHILD  | 

PRIMARY_RELATION  =  UNCLE  | 

PRIMARY_RELATION  =  NEPHEW 
then 

do;       /*  write  generation-qualifier  */ 
if  THIS_GENERATION_GAP  >=  3  then 
do ; 

DISPLAY_BUFFER  =  DISPLAY_BUFFER   ||  'great'; 
if  THIS_GENERATION_GAP  >  3  then 

DISPLAY_BUFFER  =  DISPLAY_BUFFER   | |   '*'    | | 
TRIM  (THIS_GENERATION_GAP  -  2); 
DISPLAY_BUFFER  =  DISPLAYJBUFFER   ||  '-'; 
end; 

if  THIS_GENERATION_GAP  >=  2  then 

DISPLAY_BUFFER  =  DISPLAY_BUFFER   ||  'grand-'; 
end; 
else 

if  (PRIMARY_RELATION  =  COUSIN)  &  (THIS_COUSIN_RANK  >  1)  then 
do ; 

DISPLAY_BUFFER  =  DISPLAYJBUFFER   ||  TRIM  (THIS_COUSIN_RANK) ; 
SUFFIX_INDICATOR  =  mod  (THIS_COUSIN_RANK,  10); 
if  SUFFIX_INDICATOR  >  3  then 

SUFFIX_INDICATOR  =0; 
DISPLAYJBUFFER  =  DISPLAY_BUFFER   | | 

substr  ('th  St  nd  rd  ',  3  *  SUFFIX_INDICATOR  +  1,  3); 
end; 


\ 
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if  THIS_PROXIMITY  =  STEP  then 

DISPLAY_BUFFEPv  =  DISPLAYJBUFFER   ||  'step-'; 
else 

If  THISJPROXIMITY  =  HALF  then 

DISPLAY  BUFFER  =  DISPLAY  BUFFER   ||  'half-' 


THIS_GENDER  =  PERSON  (KEY_PERSON  (FIRST_INDEX) 

if  PRIMARY_RELATION  =  PARENT  then 

if  THIS_GENDER  =  MALE  then  DISPLAY_BUFFER  = 
else  DISPLAYJBUFFER  = 

else  if  PRIMARY  RELATION  =  CHILD  then 


.   PERSON  INDEX)   .  GENDER; 


if  THIS_GENDER  =  MALE 
else 


then  DISPLAY_BUFFER 
DISPLAY  BUFFER 


else  if  PRIMARY  RELATION  =  SPOUSE  then 


MALE  then  DISPLAY_BUFFER 
DISPLAY  BUFFER 


if  THIS_GENDER 

else  _ 

else  if  PRIMARY_RELATION  =  SIBLING  then 

if  THIS_GENDER  =  MALE  then  DISPLAYJBUFFER 
else  DISPLAYJBUFFER 

else  if  PRIMARY  JIELATION  =  UNCLE  then 

if  THISJSENDER  =  MALE  then  DISPLAY_BUFFER 
else  DISPLAY_BUFFER 

else  if  PRIMARY  JIELATION  =  NEPHEW  then 

if  THISJ3ENDER  =  MALE  then  DISPLAY_BUFFER 
else  DISPLAY_BUFFER 

else  if  PRIMARY  JIELATION  =  COUSIN  then 

DISPLAYJBUFFER 

else 


DISPLAY_BUFFER 
DISPLAY_BUFFER 

DISPLAY_BUFFER 
DISPLAY_BUFFER 

DISPLAY_BUFFER 
DISPLAY_BUFFER 

DISPLAY_BUFFER 
DISPLAY_BUFFER 

DISPLAY_BUFFER 
DISPLAY_BUFFER 

DISPLAYJBUFFER 
DISPLAY  BUFFER 


_  DISPLAY_BUFFER 
DISPLAY  BUFFER  =  DISPLAY  BUFFER 


'father' ; 
'mother' ; 

'  son' ; 
'daughter' ; 

'husband' ; 
'wif e' ; 

'brother' ; 
'sister' ; 

'uncle' ; 
'aunt' ; 

'nephew' ; 
'niece' ; 

'cousin' ; 

'null' ; 


if  INLAW  then 

DISPLAYJBUFFER  =  DISPLAY_BUFFER   ||  '-in-law'; 

if  (PRIMARY_RELATION  =  COUSIN)  &  (THIS_GENERATION_GAP  >  0)  then 
if  THISJ3ENERATIONJ3AP  >  1  then 

DISPLAYJBUFFER  =  DISPLAYJBUFFER   | |   '  '    I  I 

TRIM  (THISJ3ENERATIONJ3AP)   il   '  times  removed'; 

else 

DISPLAY  BUFFER  =  DISPLAY  BUFFER   ||    '  once  removed'; 


DISPLAY_BUFFER  =  DISPLAYJBUFFER  ||  '  of; 
put  skip  list  (DISPLAY_BUFFER); 
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/*  Begin  utility  procedure  for  DISPLAY_RELATION  */ 

TRIM:  procedure  (NUMERIC_VALUE)  returns  (character  (20)  varying); 
/*  Returns  character  representation  of  numeric  values 

with  no  leading  or  trailing  spaces.  */ 
declare 

NUMERIC_VALUE     fixed  binary  (10,0); 
declare 

STRING_REPRESENTATION  character  (20), 
(START_LOCATION,  STOP_LOCATION) 

fixed  binary  (10,0); 
/*  Begin  execution  of  TRIM  */ 

STRING_REPRESENTATION  =  NUMERIC_VALUE ; 
do  START_L0CATI0N  =  1  to  20 

while  (substr  (STRING_REPRESENTATION,   START_L0CATI0N,   1)  =  '  '); 
end; 

do  ST0P_L0CATI0N  =  20  to  1  by  -1 

while  (substr  (STRING_REPRESENTATION,   ST0P_L0CATI0N,   1)  =  '  '); 
end; 

'   return  (substr  (STRING_REPRESENTATION,  START_L0CATI0N, 

ST0P_L0CATI0N  -  STARTJLOCATION  +1)); 

end  TRIM; 

end  DISPLAY_RELATION; 

end  RE  SOL  VE_P  ATH_T0_ENGLI  SH ; 

/*  C0MPUTE_C0MM0N_GENES  is  second  major  procedure  (after 
RESOLVE_PATH_TO_ENGLISH)  under  FIND_RELATIONSHIP.  */ 

COMPUTE_COMMON_GENES:  procedure  (INDEXl,  INDEX2); 

/*  COMPUTE_COMMON_GENES  assumes  that  each  ancestor  contributes 
half  of  the  genetic  material  to  a  PERSON.     It  finds  common 
ancestors  between  two  PERSONS  and  computes  the  expected 
value  of  the  PROPORTION  of  common  material.  */ 

declare 

(INDEXl,   INDEX2)  fixed  binary  (10,0); 
declare 

C0MM0N_PR0P0RTI0N  float  decimal  (6); 

/*  begin  execution  of  C0MPUTE_C0MM0N_GENES  */ 

/*  First  zero  out  all  ancestors  to  allow  adding.     This  is  necessary 

because  there  might  be  two  paths  to  an  ancestor.  */ 
call  ZERO_PROPORTION  (INDEXl); 
/*  now  mark  with  shared  PROPORTION  */ 

call  MARK_PROPORTION  (PERSON  (INDEXl)   .   IDENTIFIER,    1.0,  INDEXl); 
COMMON_PRO PORTION  =0.0; 

call  CHECK_COMMON_PRO PORTION  (COMMONJPROPORTION, 

PERSON  (INDEXl)   .   IDENTIFIER,   1.0,   0.0,  INDEX2 ) ; 
put  skip  list  ('  Proportion  of  common  genetic  material  =  '); 
put  edit  (C0MM0N_PR0 PORTION)  (e(13,5,6)); 

/*  End  execution  of  COMPUTE  COMMON  GENES. 
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Begin  utility  procedures.  */ 


ZERO_PRO PORTION:  procedure  (ZERO_INDEX)  recursive; 

/*  ZERO_PROPORTION  recursively  seeks  out  all  ancestors  and 
zeros  them  out.  */ 

declare 

ZERO_INDEX  fixed  binary  (10,0), 

THIS_NEIGHBOR  pointer; 
/*  begin  execution  of  ZERO_PROPORTION  */ 

PERSON  (ZERO_INDEX)   .   DESCENDANT_GENES  =  0.0; 
THIS_NEIGHB0R  =  PERSON  (ZERO_INDEX)   .  NEIGHBOR_LIST_HEADER ; 
do  while  (THIS_NEIGHBOR  ~=  null()); 

if  THIS_NEIGHBOR  ->  NEIGHBOR_EDGE  =  PARENT  then 

call  ZERO_PRO PORTION  (THIS_NEIGHBOR  ->  NEIGHBOR_INDEX) ; 
THISJJEIGHBOR  =  THIS_NEIGHBOR  ->  NEXTJJEIGHBOR; 
end; 

end  ZERO_PRO PORTION; 

MARKPRO PORTION:  procedure  (MARKER,  PROPORTION,  MARKED_INDEX)  recursive; 
/*  MARK_PROPORTION  recursively  seeks  out  all  ancestors  and 
marks  them  with  the  sender's  PROPORTION  of  shared 
genetic  material.     This  PROPORTION  is  diluted  by  one-half 
for  each  generation.  */ 


declare 

MARKER  picture  '999', 

PROPORTION  float  decimal  (6), 

MARKED_INDEX  fixed  binary  (10,0), 

THIS_NEIGHBOR  pointer ; 

/*  begin  execution  of  MARK_PRO PORTION  */ 

PERSON  (MARKED_INDEX)   .  DESCENDANT_IDENTIFIER  =  MARKER; 
PERSON  (MARKED_INDEX)   .  DESCENDANT_GENES 

PERSON  (MARKED_INDEX)   .  DESCENDANT_GENES  +  PROPORTION; 
THISJJEIGHBOR  =  PERSON  (MARKED_INDEX)   .  NEIGHBOR_LIST_HEADER; 
do  while  (THIS_NEIGHBOR  ~=  null()); 

if  THIS_NEIGHBOR  ->  NEIGHBOR_EDGE  =  PARENT  then 
call  MARK_PROPORTION  (MARKER,   PROPORTION  /  2.0, 

THISJJEIGHBOR  ->  NEIGHBOR_INDEX) ; 
THIS_NEIGHBOR  =  THISJJEIGHBOR  ->  NEXTJJEIGHBOR; 
end; 

end  MARK  PROPORTION; 
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CHECK_COMMON_PROPORTION:  procedure 

(COMMON_PROPORTION,  MATCH_IDENTIFIER,  PROPORTION, 
ALREADY_COUNTED,  CHECK_INDEX)  recursive; 
/*  CHECK_COMMON_PROPORTION  searches  all  the  ancestors  of 
CHECK_INDEX  to  see  if  any  have  been  marked,  and  if  so 
adds  The  appropriate  amount  to  COMMON_PRO PORTION.  */ 

declare 

COMMON_PROPORTION  float  decimal  (6), 
MATCH_IDENTIFIER    picture  '999', 
PROPORTION  float  decimal  (6), 

ALREADY_COUNTED      float  decimal  (6), 
CHECK_INDEX  fixed  binary  (10,0), 

THIS_NEIGHBOR  pointer, 
THIS_CONTRIBUTION  float  decimal  (6); 

/*  begin  execution  of  CHECK_COMMON_PROPORTION  */ 

if  PERSON  (CHECK_INDEX)   .  DESCENDANT_IDENTIFIER  =  MATCH_IDENTIFIER  then 
/*  Increment  COMMON_PROPORTION  by  the  contribution  of 

this  common  ancestor,  but  discount  for  the  contribution 
of  less  remote  ancestors  already  counted.  */ 

do ; 

THIS_CONTRIBUTION  =  PERSON  (CHECK_INDEX)   .  DESCENDANT_GENES 

*  PROPORTION; 
COMMON_PROPORTION  =  COMMON_PROPORTION 

+  THISJGONTRIBUTION  -  ALREADY_COUNTED; 
end; 
else 

THISJGONTRIBUTION  =  0.0; 
THIS_NEIGHBOR  =  PERSON  (CHECK_INDEX)   .  NEIGHBOR_LIST_HEADER; 
do  while  (THIS_NEIGHBOR  ~=  null()); 

if  THIS_NEIGHBOR  ->  NEIGHBOR_EDGE  =  PARENT  then 

call  CHECK_COMMON_PRO PORTION  (COMMON_PRO PORTION, 
MATCH_IDENTIFIER,   PROPORTION  /  2.0, 
THISJGONTRIBUTION  /  4.0, 
THISJJEIGHBOR  ->  NEIGHBOR_INDEX) ; 
THIS_NEIGHBOR  =  THIS_NEIGHBOR  ->  NEXT_NEIGHBOR; 
end; 

end  CHECKjGOMMON_PRO PORTION; 
end  COMPUTEjGOMMON_GENES ; 
end  FIND  RELATIONSHIP; 


end  RELATE; 
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Programming  languages  have  been  and  will  continue  to  be  an  important  instrument 
for  the  automation  of  a  wide  variety  of  functions  within  industry  and  the  Federal 
Government.    Other  instruments,  such  as  program  generators,  application  packages, 
query  languages,  and  the  like,  are  also  available  and  their  use  is  preferable  in 
some  circumstances. 

Given  that  conventional  programming  is  the  appropriate  technique  for  a  particu- 
lar application,  the  choice  among  the  various  languages  becomes  an  important  issue. 
There  are  a  great  number  of  selection  criteria,  not  all  of  which  depend  directly  on 
the  language  itself.    Broadly  speaking,  the  criteria  are  based  on  1)  the  language 
and  its  implementation,  2)  the  application  to  be  programmed,  and  3)  the  user's 
existing  facilities  and  software. 

This  study  presents  a  survey  of  selection  factors  for  the  major  general -purpose 
languages:    Ada,    BASIC,  C,  COBOL,  FORTRAN,  Pascal,  and  PL/I.    The  factors  covered 
include  not  only  the  logical  operations  within  each  language,  but  also  the  advantages 
and  disadvantages  stemming  from  the  current  computing  environment,  e.g 
packages,  microcomputers,  and  standards.    The  criteria  associated  with 
tion  and  the  user's  facilities  are  explained.    Finally,  there  is  a  set 
examples  to  illustrate  the  features  of  the  various  languages. 

This  volume  includes  the  program  examples.    Volume  1  contains  the  discussion  of 
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ming 1  anguage  features ;  programming  languages;  selection  of  programming  language. 
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I    Technical  Publications 


Periodicals 


Journal  of  Research — The  Journal  of  Research  of  the  National  Bureau  of  Standards  reports  NBS  research 
and  development  in  those  disciplines  of  the  physical  and  engineering  sciences  in  which  the  Bureau  is  active. 
These  include  physics,  chemistry,  engineering,  mathematics,  and  computer  sciences.  Papers  cover  a  broad 
range  of  subjects,  with  major  emphasis  on  measurement  methodology  and  the  basic  technology  underlying 
standardization.  Also  included  from  time  to  time  are  survey  articles  on  topics  closely  related  to  the  Bureau's 
technical  and  scientific  programs.  As  a  special  service  to  subscribers  each  issue  contains  complete  citations  to 
all  recent  Bureau  publications  in  both  NBS  and  non-NBS  media.  Issued  six  times  a  year. 


Nonperiodiccds 

Monographs — Major  contributions  to  the  technical  literature  on  various  subjects  related  to  the  Bureau's  scien- 
tific and  technical  activities. 

Handbooks — Recommended  codes  of  engineering  and  industrial  practice  (including  safety  codes)  developed  in 
cooperation  with  interested  industries,  professional  organizations,  and  regulatory  bodies. 

Special  Publications — Include  proceedings  of  conferences  sponsored  by  NBS,  NBS  annual  reports,  and  other 
special  publications  appropriate  to  this  grouping  such  as  wall  charts,  pocket  cards,  and  bibliographies. 

Applied  Mathematics  Series — Mathematical  tables,  manuals,  and  studies  of  special  interest  to  physicists, 
engineers,  chemists,  biologists,  mathematicians,  computer  programmers,  and  others  engaged  in  scientific  and 
technical  work. 

National  Standard  Reference  Data  Series — Provides  quantitative  data  on  the  physical  and  chemical  properties 
of  materials,  compiled  from  the  world's  literature  and  critically  evaluated.  Developed  under  a  worldwide  pro- 
gram coordinated  by  NBS  under  the  authority  of  the  National  Standard  Data  Act  (Public  Law  90-396). 
NOTE:  The  Journal  of  Physical  and  Chemical  Reference  Data  (JPCRD)  is  published  quarterly  for  NBS  by 
the  American  Chemical  Society  (ACS)  and  the  American  Institute  of  Physics  (AIP).  Subscriptions,  reprints, 
and  supplements  are  available  from  ACS,  1155  Sixteenth  St.,  NW,  Washington,  DC  20056. 

Building  Science  Series — Disseminates  technical  information  developed  at  the  Bureau  on  building  materials, 
components,  systems,  and  whole  structures.  The  series  presents  research  results,  test  methods,  and  perfor- 
mance criteria  related  to  the  structural  and  environmental  functions  and  the  durability  and  safety 
characteristics  of  building  elements  and  systems. 

Technical  Notes — Studies  or  reports  which  are  complete  in  themselves  but  restrictive  in  their  treatment  of  a 
subject.  Analogous  to  monographs  but  not  so  comprehensive  in  scope  or  definitive  in  treatment  of  the  subject 
area.  Often  serve  as  a  vehicle  for  final  reports  of  work  performed  at  NBS  under  the  sponsorship  of  other 
government  agencies. 

Voluntary  Product  Standards — Developed  under  procedures  published  by  the  Department  of  Commerce  in 
Part  10,  Title  15,  of  the  Code  of  Federal  Regulations.  The  standards  establish  nationally  recognized  re- 
quirements for  products,  and  provide  all  concerned  interests  with  a  basis  for  common  understanding  of  the 
characteristics  of  the  products.  NBS  administers  this  program  as  a  supplement  to  the  activities  of  the  private 
sector  standardizing  organizations. 

Consumer  Information  Series — Practical  information,  based  on  NBS  research  and  experience,  covering  areas 
of  interest  to  the  consumer.  Easily  understandable  language  and  illustrations  provide  useful  background 
knowledge  for  shopping  in  today's  technological  marketplace. 

Order  the  above  NBS  publications  from:  Superintendent  of  Documents,  Government  Printing  Office, 
Washington,  DC  20402. 

Order  the  following  NBS  publications— FIPS  and  NBSIR  's—from  the  National  Technical  Information  Ser- 
vice, Springfield,  VA  22161. 

Federal  Information  Processing  Standards  Publications  (FIPS  PUB) — Publications  in  this  series  collectively 
constitute  the  Federal  Information  Processing  Standards  Register.  The  Register  serves  as  the  official  source  of 
information  in  the  Federal  Government  regarding  standards  issued  by  NBS  pursuant  to  the  Federal  Property 
and  Administrative  Services  Act  of  1949  as  amended.  Public  Law  89-306  (79  Stat.  1127),  and  as  implemented 
by  Executive  Order  11717  (38  FR  12315,  dated  May  II,  1973)  and  Part  6  of  Title  15  CFR  (Code  of  Federal 
Regulations). 

NBS  Interagency  Reports  (NBSIR)— A  special  series  of  interim  or  final  reports  on  work  performed  by  NBS 
for  outside  sponsors  (both  government  and  non-government).  In  general,  initial  distribution  is  handled  by  the 
sponsor;  public  distribution  is  by  the  National  Technical  Information  Service,  Springfield,  VA  22161,  in  paper 
copy  or  microfiche  form. 
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